From c1cab874c739c9b08ff28d3d67757e59a75531bf Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 18 Dec 2014 07:52:34 +0000 Subject: travis-ci: test with HEAD --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index ad1331f8..9161d8db 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,6 +3,7 @@ language: haskell env: # - GHCVER=7.8.2 # - GHCVER=7.8.3 + - GHCVER=head before_install: - sudo add-apt-repository -y ppa:hvr/ghc -- cgit v1.2.3 From 43d0789910061eda305141ca19c35e51d3888188 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Mon, 29 Dec 2014 15:28:47 +0000 Subject: Make travis use 7.10.x --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 9161d8db..f0b7eb10 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ language: haskell env: # - GHCVER=7.8.2 # - GHCVER=7.8.3 - - GHCVER=head + - GHCVER=7.10.1 before_install: - sudo add-apt-repository -y ppa:hvr/ghc -- cgit v1.2.3 From 9bd2bf9e8cbf1b2cc2affd27096b79d149528c5b Mon Sep 17 00:00:00 2001 From: Njagi Mwaniki Date: Sat, 27 Dec 2014 23:28:59 +0300 Subject: Turn the README into GitHub Markdown format. Closes #354 --- README | 37 ------------------------------------- README.md | 47 +++++++++++++++++++++++++++++++++++++++++++++++ doc/README | 26 -------------------------- doc/README.md | 25 +++++++++++++++++++++++++ 4 files changed, 72 insertions(+), 63 deletions(-) delete mode 100644 README create mode 100644 README.md delete mode 100644 doc/README create mode 100644 doc/README.md diff --git a/README b/README deleted file mode 100644 index 53f84bf0..00000000 --- a/README +++ /dev/null @@ -1,37 +0,0 @@ -Haddock, a Haskell Documentation Tool -===================================== - -This is Haddock, a tool for automatically generating documentation -from annotated Haskell source code. It is primary intended for -documenting library interfaces, but it should be useful for any kind -of Haskell code. - -Haddock lets you write documentation annotations next to the -definitions of functions and types in the source code, in a syntax -that is easy on the eye when writing the source code (no heavyweight -mark-up). The documentation generated by Haddock is fully hyperlinked -- click on a type name in a type signature to go straight to the -definition, and documentation, for that type. - -Haddock understands Haskell's module system, so you can structure your -code however you like without worrying that internal structure will be -exposed in the generated documentation. For example, it is common to -implement a library in several modules, but define the external API by -having a single module which re-exports parts of these implementation -modules. Using Haddock, you can still write documentation annotations -next to the actual definitions of the functions and types in the -library, but the documentation annotations from the implementation -will be propagated to the external API when the documentation is -generated. Abstract types and classes are handled correctly. In -fact, even without any documentation annotations, Haddock can generate -useful documentation from your source code. - -Haddock can generate documentation in multiple formats; currently HTML -is implemented, and there is partial support for generating LaTeX and -Hoogle. - -Full documentation can be found in the doc/ subdirectory, in DocBook -format. - -Please create issues when you have any problems and pull requests if -you have some code. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 00000000..b85d99b7 --- /dev/null +++ b/README.md @@ -0,0 +1,47 @@ +# Haddock, a Haskell Documentation Tool + + +#### About haddock + +This is Haddock, a tool for automatically generating documentation +from annotated Haskell source code. It is primary intended for +documenting library interfaces, but it should be useful for any kind +of Haskell code. + +Haddock lets you write documentation annotations next to the +definitions of functions and types in the source code, in a syntax +that is easy on the eye when writing the source code (no heavyweight +mark-up). The documentation generated by Haddock is fully hyperlinked +- click on a type name in a type signature to go straight to the +definition, and documentation, for that type. + +Haddock understands Haskell's module system, so you can structure your +code however you like without worrying that internal structure will be +exposed in the generated documentation. For example, it is common to +implement a library in several modules, but define the external API by +having a single module which re-exports parts of these implementation +modules. Using Haddock, you can still write documentation annotations +next to the actual definitions of the functions and types in the +library, but the documentation annotations from the implementation +will be propagated to the external API when the documentation is +generated. Abstract types and classes are handled correctly. In +fact, even without any documentation annotations, Haddock can generate +useful documentation from your source code. + + +#### Documentation formats + +Haddock can generate documentation in multiple formats; currently HTML +is implemented, and there is partial support for generating LaTeX and +Hoogle. + + +#### Source code documentation + +Full documentation can be found in the doc/ subdirectory, in DocBook +format. + + +#### Contributing + +Please create issues when you have any problems and pull requests if you have some code. diff --git a/doc/README b/doc/README deleted file mode 100644 index 5bc038bf..00000000 --- a/doc/README +++ /dev/null @@ -1,26 +0,0 @@ -Haddock documentation ---------------------- - -The documentation is in DocBook XML format. You need some tools to -process it: at least xsltproc, and the DocBook XML DTD and XSL -stylesheets. There's a configure script to detect the right way to -process the documentation on your system, and a Makefile to actually -do the processing (so, on Windows, you'll need Cygwin or MSys in -addition to the DocBook XML tools). To build the HTML documentation: - - $ autoconf - $ ./configure - $ make html - -which leaves the HTML documentation in a haddock/ subdirectory. - -Printable documentation can also be produced, eg.: - - $ make pdf - -or - - $ make ps - -Generating the printed formats requires more tools (fop or xmltex) and -tends to be a bit harder. diff --git a/doc/README.md b/doc/README.md new file mode 100644 index 00000000..cf1fc31b --- /dev/null +++ b/doc/README.md @@ -0,0 +1,25 @@ +# Haddock documentation + +The documentation is in DocBook XML format. You need some tools to +process it: at least xsltproc, and the DocBook XML DTD and XSL +stylesheets. There's a configure script to detect the right way to +process the documentation on your system, and a Makefile to actually +do the processing (so, on Windows, you'll need Cygwin or MSys in +addition to the DocBook XML tools). To build the HTML documentation: + + $ autoconf + $ ./configure + $ make html + +which leaves the HTML documentation in a haddock/ subdirectory. + +Printable documentation can also be produced, eg.: + + $ make pdf + +or + + $ make ps + +Generating the printed formats requires more tools (fop or xmltex) and +tends to be a bit harder. -- cgit v1.2.3 From 959d205924694fa4a803932ba80d2cb68f08989f Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Mon, 5 Jan 2015 16:25:37 +0100 Subject: bump haddock-api ghc dependency to allow release candidate and first release --- haddock-api/haddock-api.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b2199c68..22b3ae57 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -45,7 +45,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 - , ghc == 7.9.* + , ghc >= 7.10 && < 7.10.2 , ghc-paths , haddock-library == 1.2.0.* -- cgit v1.2.3 From 7b65f556c1087f205eaa45b8592dfa687e78c669 Mon Sep 17 00:00:00 2001 From: JP Moresmau Date: Wed, 21 Jan 2015 16:34:08 +0100 Subject: Ignore warnings, install Cabal 1.22 --- .travis.yml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index f0b7eb10..ab3388cf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,14 +10,18 @@ before_install: - sudo apt-get update - sudo apt-get install ghc-$GHCVER - export PATH=/opt/ghc/$GHCVER/bin:$PATH + - sudo apt-get install cabal-install-1.22 + - export PATH=/opt/cabal/1.22/bin:$PATH + - cabal --version - cd haddock-library - cabal install --only-dependencies --enable-tests - cabal install doctest - - cabal configure --enable-tests --ghc-options=-Werror && cabal build && cabal test + # --ghc-options=-Werror + - cabal configure --enable-tests && cabal build && cabal test - doctest -isrc -i$(echo vendor/attoparsec-*) -optP-include -optPdist/build/autogen/cabal_macros.h src/Documentation/Haddock/Parser.hs - cabal install - cd .. - - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests --ghc-options=-Werror && cabal build && cabal test && cabal install) + - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install) script: - - cabal configure --enable-tests --ghc-options=-Werror && cabal build && cabal test + - cabal configure --enable-tests && cabal build && cabal test -- cgit v1.2.3 From 08c65a9cdd3eb01b1b9e3e5d572cd1fdc1bd4188 Mon Sep 17 00:00:00 2001 From: jpmoresmau Date: Wed, 21 Jan 2015 20:10:39 +0100 Subject: solve dataDir ambiguity --- latex-test/run.lhs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/latex-test/run.lhs b/latex-test/run.lhs index c1d48d97..d3e39e90 100755 --- a/latex-test/run.lhs +++ b/latex-test/run.lhs @@ -6,7 +6,7 @@ import Control.Monad import Control.Applicative import Data.List import Data.Maybe -import Distribution.InstalledPackageInfo +import Distribution.InstalledPackageInfo hiding (dataDir) import Distribution.Package (PackageName (..)) import Distribution.Simple.Compiler import Distribution.Simple.GHC -- cgit v1.2.3 From 8d3df49ae1aa2eb58af530bba0c71817411fd49d Mon Sep 17 00:00:00 2001 From: jpmoresmau Date: Wed, 21 Jan 2015 21:31:24 +0100 Subject: support GHC 7.10: no Safe-Inferred, Foldable instance --- html-test/ref/A.html | 2 +- html-test/ref/AdvanceTypes.html | 2 +- html-test/ref/B.html | 2 +- html-test/ref/Bold.html | 2 +- html-test/ref/Bug1.html | 2 +- html-test/ref/Bug195.html | 4 ++-- html-test/ref/Bug2.html | 2 +- html-test/ref/Bug201.html | 2 +- html-test/ref/Bug26.html | 2 +- html-test/ref/Bug294.html | 2 +- html-test/ref/Bug298.html | 2 +- html-test/ref/Bug3.html | 2 +- html-test/ref/Bug308.html | 2 +- html-test/ref/Bug308CrossModule.html | 2 +- html-test/ref/Bug313.html | 2 +- html-test/ref/Bug335.html | 2 +- html-test/ref/Bug4.html | 2 +- html-test/ref/Bug6.html | 2 +- html-test/ref/Bug7.html | 2 +- html-test/ref/Bug8.html | 8 +++++--- html-test/ref/Bug85.html | 4 ++-- html-test/ref/BugDeprecated.html | 2 +- html-test/ref/BugExportHeadings.html | 2 +- html-test/ref/Bugs.html | 2 +- html-test/ref/CrossPackageDocs.html | 2 +- html-test/ref/DeprecatedClass.html | 2 +- html-test/ref/DeprecatedData.html | 2 +- html-test/ref/DeprecatedFunction.html | 2 +- html-test/ref/DeprecatedFunction2.html | 2 +- html-test/ref/DeprecatedFunction3.html | 2 +- html-test/ref/DeprecatedModule.html | 2 +- html-test/ref/DeprecatedModule2.html | 2 +- html-test/ref/DeprecatedNewtype.html | 2 +- html-test/ref/DeprecatedReExport.html | 2 +- html-test/ref/DeprecatedRecord.html | 2 +- html-test/ref/DeprecatedTypeFamily.html | 4 ++-- html-test/ref/DeprecatedTypeSynonym.html | 2 +- html-test/ref/Examples.html | 2 +- html-test/ref/Extensions.html | 2 +- html-test/ref/FunArgs.html | 2 +- html-test/ref/GADTRecords.html | 2 +- html-test/ref/Hash.html | 2 +- html-test/ref/HiddenInstances.html | 2 +- html-test/ref/HiddenInstancesB.html | 2 +- html-test/ref/Hyperlinks.html | 2 +- html-test/ref/IgnoreExports.html | 2 +- html-test/ref/ImplicitParams.html | 2 +- html-test/ref/Minimal.html | 2 +- html-test/ref/ModuleWithWarning.html | 2 +- html-test/ref/NamedDoc.html | 2 +- html-test/ref/Nesting.html | 2 +- html-test/ref/NoLayout.html | 2 +- html-test/ref/NonGreedy.html | 2 +- html-test/ref/Operators.html | 2 +- html-test/ref/PatternSyns.html | 2 +- html-test/ref/Properties.html | 2 +- html-test/ref/PruneWithWarning.html | 2 +- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/Test.html | 2 +- html-test/ref/Ticket253_1.html | 2 +- html-test/ref/Ticket253_2.html | 2 +- html-test/ref/Ticket61.html | 2 +- html-test/ref/Ticket75.html | 2 +- html-test/ref/TitledPicture.html | 2 +- html-test/ref/TypeFamilies.html | 2 +- html-test/ref/TypeFamilies2.html | 2 +- html-test/ref/TypeOperators.html | 2 +- html-test/ref/Unicode.html | 2 +- html-test/ref/Visible.html | 2 +- html-test/src/Bug8.hs | 1 + 70 files changed, 77 insertions(+), 74 deletions(-) diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 62f99ee0..96e2d001 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Produced by Haddock version 2.15.0

version 2.16.0

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

(--->) :: [a] -> :: Foldable t0 => t0 t -> Typ -> Typ

Produced by Haddock version 2.15.0

version 2.16.0

Safe HaskellSafe-InferredSafe

Produced by Haddock version 2.15.0

version 2.16.0

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Produced by Haddock version 2.15.0

version 2.16.0

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafeSafe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

Safe HaskellSafe-InferredSafe

y = Type(s,[s,t]) +(--->) :: (Foldable t0) => t0 t -> Typ -> Typ (--->) = flip $ foldr (-->) s = undefined -- cgit v1.2.3 From 2c60cb0da855d76c57980298056cefe15ff4c226 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 22 Jan 2015 19:32:10 +0000 Subject: Update test files Test: a correct behaviour for fields comma-separating values. I'm surprised we had no bug open for this. Maybe it affects how #301 renders now but I doubt. Operators: Seems GHC is giving us a new order for operators, something must have changed on their side again. cc @haasn , this makes the fixity to the side not match the order on the LHS which is a bit unpleasant. Maybe the fixity can be made to match the GHC order? Bug335: We expand examples by default now. Bug310: Now inferred safe. --- html-test/ref/Bug310.html | 4 ++-- html-test/ref/Bug335.html | 6 +++--- html-test/ref/Operators.html | 16 ++++++++-------- html-test/ref/Test.html | 40 +++++----------------------------------- 4 files changed, 18 insertions(+), 48 deletions(-) diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html index 926d6cf2..c38af59c 100644 --- a/html-test/ref/Bug310.html +++ b/html-test/ref/Bug310.html @@ -35,7 +35,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug310.html");}; >Safe HaskellNoneSafe

Produced by Haddock version 2.15.1

version 2.16.0

ExF:

abc

ExG:

>>> 
Produced by Haddock version 2.15.1
 version 2.16.0
(**>), (<**)(**<), (>**), (**<)(<**) :: a -> a -> ()

(**>), (<**), (>**), (**<), (>**), (<**) :: a -> a -> () infixr 8 **>, >**infixl 8 <**, **<infixl 8 **<, <**

Produced by Haddock version 2.15.0

version 2.16.0

  • r :: Int
  • , s :: Int
  • u :: Int
  • , v :: Int
    r :: Int

    This comment applies to both r and s

    , s :: Int
    u :: Int
     
    , v :: Int

    Produced by Haddock version 2.15.0

    version 2.16.0

    • Date: Tue, 20 Jan 2015 18:27:16 +0100 Subject: Links to source location of class instance definitions --- .../resources/html/Ocean.std-theme/ocean.css | 9 +++++ haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 ++++----- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 44 ++++++++++++++++------ .../src/Haddock/Interface/AttachInstances.hs | 11 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 +- haddock-api/src/Haddock/Types.hs | 4 +- 7 files changed, 62 insertions(+), 32 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index de436324..f762e832 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -378,6 +378,15 @@ div#style-menu-holder { margin: 0 -0.5em 0 0.5em; } +#interface td.src .link { + float: right; + color: #919191; + border-left: 1px solid #919191; + background: #f0f0f0; + padding: 0 0.5em 0.2em; + margin: 0 -0.5em 0 0.5em; +} + #interface span.fixity { color: #919191; border-left: 1px solid #919191; diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b717fc01..ee5bc861 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing) = Just i +isUndocdInstance (L _ i,Nothing) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, doc) = +ppDocInstance unicode (L _ instHead, doc) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3bf4322d..d24a3f04 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl ( tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names @@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances instances docname unicode qual + = ppInstances links instances docname unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances links instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) +ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html +ppInstances links instances baseName unicode qual + = subInstances qual instName links True baseName (map instDecl instances) + -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instDecl :: DocInstance DocName -> (SubDecl,SrcSpan) + instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" @@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links instances docname unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index b2c60534..923958a7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -148,6 +148,20 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs +-- | Sub table with source information (optional). +subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) + where + subRow ((decl, mdoc, subs),loc) = + (td ! [theclass "src"] << decl + <+> linkHtml loc + <-> + docElement td << fmap (docToHtml Nothing qual) mdoc + ) + : map (cell . (td <<)) subs + linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn + linkHtml _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -174,13 +188,15 @@ subEquations :: Qualification -> [SubDecl] -> Html subEquations qual = divSubDecls "equations" "Equations" . subTable qual +-- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable + -> LinksInfo -> Bool -> DocName + -> [(SubDecl,SrcSpan)] -> Html +subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -200,12 +216,19 @@ declElem = paragraph ! [theclass "src"] -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) +topDeclElem lnks loc splice names html = + declElem << (html <+> (links lnks loc splice $ head names)) + -- FIXME: is it ok to simply take the first name? + +-- | Adds a source and wiki link at the right hand side of the box. +-- Name must be documented, otherwise we wouldn't get here. +links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) = + (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl - -- Use the lineUrl as a backup + -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml @@ -227,10 +250,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm origMod = nameModule n origPkg = modulePackageKey origMod - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? - fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "links: UnhelpfulSpan" +links _ _ _ _ = noHtml diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 1341e57f..37203d63 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -72,21 +72,22 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, n) + let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc) | i <- sortBy (comparing instFam) fam_instances - , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap , not $ isNameHidden expInfo (fi_fam i) , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _) <- fam_insts ] + cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ] + famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1ea212f5..7b9481fe 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -499,10 +499,10 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc) -> do + instances' <- forM instances $ \(L l inst, idoc) -> do inst' <- renameInstHead inst idoc' <- mapM renameDoc idoc - return (inst', idoc') + return (L l inst', idoc') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e93294a0..ae90ff07 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -300,8 +300,8 @@ instance OutputableBndr a => Outputable (InstType a) where ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a --- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (MDoc name)) +-- | An instance head that may have documentation and a source location. +type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type -- cgit v1.2.3 From 41e146b93456e5181df479952f066d747d8dcb83 Mon Sep 17 00:00:00 2001 From: Vincent Berthoux Date: Wed, 21 Jan 2015 23:11:12 +0100 Subject: Filter '\r' from comments due to Windows problems. On Windows this was causing newline to be rendered twice in code blocks. Closes #359, fixes #356. --- haddock-library/src/Documentation/Haddock/Parser.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index b7ab85b0..5c607a1a 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -93,7 +93,8 @@ parseParas input = case parseParasState input of } parseParasState :: String -> (ParserState, DocH mod Identifier) -parseParasState = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") +parseParasState = + parse (p <* skipSpace) . encodeUtf8 . (++ "\n") . filter (/= '\r') where p :: Parser (DocH mod Identifier) p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") @@ -105,7 +106,7 @@ parseParagraphs input = case parseParasState input of -- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which -- drops leading whitespace and encodes the string to UTF8 first. parseString :: String -> DocH mod Identifier -parseString = parseStringBS . encodeUtf8 . dropWhile isSpace +parseString = parseStringBS . encodeUtf8 . dropWhile isSpace . filter (/= '\r') parseStringBS :: BS.ByteString -> DocH mod Identifier parseStringBS = snd . parse p -- cgit v1.2.3 From fe10d3082457f744fd27bbb1085edcfd813f6290 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 22 Jan 2015 20:31:27 +0000 Subject: Changelog only --- CHANGES | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGES b/CHANGES index 5688537d..d98f7e1e 100644 --- a/CHANGES +++ b/CHANGES @@ -26,6 +26,10 @@ Changes in version 2.16.0 * properly render package ID (not package key) in index (#329) + * links to source location of class instance definitions + + * Fix code blocks in presence of Windows line endings + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) -- cgit v1.2.3 From 8e06728afb0784128ab2df0be7a5d7a191d30ff4 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 22 Jan 2015 23:34:05 +0000 Subject: --package-name and --package-version flags Used for --hoogle amongst other things. Now we need to teach cabal to use it. The situation is still a bit sub-par because if the flags aren't passed in, the crash will occur. Closes #353. --- haddock-api/src/Haddock.hs | 27 ++++++++++++++++++++++++--- haddock-api/src/Haddock/GhcUtils.hs | 14 -------------- haddock-api/src/Haddock/Options.hs | 37 +++++++++++++++++++++++++++++-------- 3 files changed, 53 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 915ad47a..72c544e1 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -25,6 +25,7 @@ module Haddock ( withGhc ) where +import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX @@ -36,7 +37,6 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils -import Haddock.GhcUtils hiding (pretty) import Control.Monad hiding (forM_) import Data.Foldable (forM_) @@ -66,9 +66,9 @@ import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) import StaticFlags (discardStaticFlags) +import Packages import Panic (handleGhcException) import Module -import PackageConfig import FastString -------------------------------------------------------------------------------- @@ -252,7 +252,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgMod = ifaceMod (head ifaces) pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo dflags pkgMod + (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -299,6 +299,27 @@ render dflags flags qual ifaces installedIfaces srcMap = do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir +-- | From GHC 7.10, this function has a potential to crash with a +-- nasty message such as @expectJust getPackageDetails@ because +-- package name and versions can no longer reliably be extracted in +-- all cases: if the package is not installed yet then this info is no +-- longer available. The @--package-name@ and @--package-version@ +-- Haddock flags allow the user to specify this information and it is +-- returned here if present: if it is not present, the error will +-- occur. Nasty but that's how it is for now. Potential TODO. +modulePackageInfo :: DynFlags + -> [Flag] -- ^ Haddock flags are checked as they may + -- contain the package name or version + -- provided by the user which we + -- prioritise + -> Module -> (PackageName, Data.Version.Version) +modulePackageInfo dflags flags modu = + (fromMaybe (packageName pkg) (optPackageName flags), + fromMaybe (packageVersion pkg) (optPackageVersion flags)) + where + pkg = getPackageDetails dflags (modulePackageKey modu) + + ------------------------------------------------------------------------------- -- * Reading and dumping interface files ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5aa9b818..416f5d71 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,18 +16,14 @@ module Haddock.GhcUtils where -import Data.Version import Control.Applicative ( (<$>) ) import Control.Arrow -import Data.Foldable hiding (concatMap) import Data.Function -import Data.Traversable import Exception import Outputable import Name import Lexeme -import Packages import Module import RdrName (GlobalRdrEnv) import GhcMonad (withSession) @@ -40,15 +36,6 @@ import Class moduleString :: Module -> String moduleString = moduleNameString . moduleName - --- return the (name,version) of the package -modulePackageInfo :: DynFlags -> Module -> (PackageName, Version) -modulePackageInfo dflags modu = - (packageName pkg, packageVersion pkg) - where - pkg = getPackageDetails dflags (modulePackageKey modu) - - lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of @@ -288,4 +275,3 @@ setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f - diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 3fa6397f..e847333e 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -28,15 +28,21 @@ module Haddock.Options ( qualification, verbosity, ghcFlags, - readIfaceArgs + readIfaceArgs, + optPackageName, + optPackageVersion ) where -import Distribution.Verbosity -import Haddock.Utils -import Haddock.Types -import System.Console.GetOpt import qualified Data.Char as Char +import Data.Version +import Distribution.Verbosity +import FastString +import Haddock.Types +import Haddock.Utils +import Packages +import System.Console.GetOpt +import qualified Text.ParserCombinators.ReadP as RP data Flag @@ -83,7 +89,9 @@ data Flag | Flag_Qualification String | Flag_PrettyHtml | Flag_NoPrintMissingDocs - deriving (Eq) + | Flag_PackageName String + | Flag_PackageVersion String + deriving (Eq, Show) options :: Bool -> [OptDescr Flag] @@ -107,7 +115,7 @@ options backwardsCompat = Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) - "output for Hoogle", + "output for Hoogle; you may want --package-name and --package-version too", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -171,7 +179,11 @@ options backwardsCompat = Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) - "don't print information about any undocumented entities" + "don't print information about any undocumented entities", + Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") + "name of the package being documented", + Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") + "version of the package being documented in usual x.y.z.w format" ] @@ -192,6 +204,15 @@ parseHaddockOpts params = usage <- getUsage throwE (concat errors ++ usage) +optPackageVersion :: [Flag] -> Maybe Data.Version.Version +optPackageVersion flags = + let ver = optLast [ v | Flag_PackageVersion v <- flags ] + in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion + +optPackageName :: [Flag] -> Maybe PackageName +optPackageName flags = + optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ] + optTitle :: [Flag] -> Maybe String optTitle flags = -- cgit v1.2.3 From bf77580eb40fa960b701296ac828372d127a43dd Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 22 Jan 2015 23:43:18 +0000 Subject: Sort out some module import warnings --- haddock-api/src/Haddock/Convert.hs | 1 - haddock-api/src/Haddock/Interface/Rename.hs | 3 +-- haddock-api/src/Haddock/Types.hs | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 1b1a8a88..b52c3319 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -23,7 +23,6 @@ import CoAxiom import ConLike import Data.Either (lefts, rights) import Data.List( partition ) -import Data.Monoid (mempty) import DataCon import FamInstEnv import Haddock.Types diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7b9481fe..7f69b91e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -13,7 +13,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse, Traversable) +import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types @@ -28,7 +28,6 @@ import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Data.Traversable (mapM) import Prelude hiding (mapM) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ae90ff07..f9cf6e17 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -34,7 +34,6 @@ import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) import OccName import Outputable -import Control.Applicative (Applicative(..)) import Control.Monad (ap) ----------------------------------------------------------------------------- -- cgit v1.2.3 From df0239b587e2a25531962f5b46f715ebb9b09685 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Thu, 8 Jan 2015 15:50:22 +0000 Subject: Track naming change in DataCon (cherry picked from commit 04cf63d0195837ed52075ed7d2676e71831e8a0b) --- haddock-api/src/Haddock/Convert.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b52c3319..ac7f8bd8 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -264,15 +264,15 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsUserBang (Just True) True - HsStrict -> HsUserBang (Just False) True + HsUnpack {} -> HsSrcBang (Just True) True + HsStrict -> HsSrcBang (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn _ -> noLoc $ HsBangTy bang tySyn -- HsNoBang never appears, it's implied instead. ) - arg_tys (dataConStrictMarks dc) + arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys -- cgit v1.2.3 From 89fc5605c865d0e0ce5ed7e396102e678426533b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Sep 2014 01:03:27 -0500 Subject: Follow API changes in D538 Signed-off-by: Austin Seipp (cherry picked from commit d61bbc75890e4eb0ad508b9c2a27b91f691213e6) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 +++++++++++++------------- haddock-api/src/Haddock/Convert.hs | 22 +++++++++++----------- haddock-api/src/Haddock/GhcUtils.hs | 14 +++----------- haddock-api/src/Haddock/Interface/Create.hs | 18 +++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 18 +++++++++--------- haddock-api/src/Haddock/Utils.hs | 4 ++-- 8 files changed, 61 insertions(+), 69 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index dd10bb0a..fe656a4b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -145,7 +145,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig sig) = MinimalSig sig + addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d @@ -189,7 +189,7 @@ ppCtor dflags dat subdocs con where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat + f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] @@ -203,7 +203,7 @@ ppCtor dflags dat subdocs con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT x -> x + ResTyGADT _ x -> x --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ee5bc861..125e1b3a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -477,7 +477,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -486,13 +486,13 @@ ppClassHdr summ lctxt n tvs fds unicode = <+> ppFds fds unicode -ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) + fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + hsep (map (ppDocName . unLoc) vars2) ppClassDecl :: [DocInstance DocName] -> SrcSpan @@ -598,8 +598,8 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ -> (decltt (keyword "where"), repeat empty) - _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing @@ -636,7 +636,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl - RecCon fields -> + RecCon (L _ fields) -> (decltt (header_ unicode <+> ppOcc) <-> rDoc mbDoc <+> nl) $$ @@ -648,11 +648,11 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy @@ -948,8 +948,8 @@ ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u ppr_tylit :: HsTyLit -> Bool -> LaTeX -ppr_tylit (HsNumTy n) _ = integer n -ppr_tylit (HsStrTy s) _ = text (show s) +ppr_tylit (HsNumTy _ n) _ = integer n +ppr_tylit (HsStrTy _ s) _ = text (show s) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d24a3f04..405a13f8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -145,7 +145,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -380,7 +380,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -389,13 +389,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual = <+> ppFds fds unicode qual -ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html +ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map (ppDocName qual Prefix True) + ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] @@ -469,7 +469,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of + minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] @@ -572,7 +572,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml | otherwise = case resTy of - ResTyGADT _ -> keyword "where" + ResTyGADT _ _ -> keyword "where" _ -> noHtml constrBit = subConstructors qual @@ -600,7 +600,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) - RecCon fields -> + RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') @@ -609,7 +609,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) @@ -617,7 +617,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) -- (except each field gets its own line in docs, to match -- non-GADT records) - RecCon fields -> (ppOcc <+> dcolon unicode <+> + RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) @@ -682,7 +682,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT resTy -> case con_details con of + 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 @@ -690,7 +690,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy fieldPart = case con_details con of - RecCon fields -> [doRecordFields fields] + RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual @@ -907,8 +907,8 @@ ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name 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_tylit (HsNumTy _ n) = toHtml (show n) +ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ac7f8bd8..5cbf5f97 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,7 +31,7 @@ import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn import PrelNames (ipClassName) -import SrcLoc ( Located, noLoc, unLoc ) +import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) @@ -74,9 +74,9 @@ tyThingToLHsDecl t = case t of , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ + (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -145,7 +145,7 @@ 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 (getName fakeTyVar) + = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) @@ -264,8 +264,8 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang (Just True) True - HsStrict -> HsSrcBang (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) True + HsStrict -> HsSrcBang Nothing (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn @@ -278,13 +278,13 @@ synifyDataCon use_gadt_syntax dc = (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon field_tys + (True,False) -> return $ RecCon (noLoc field_tys) (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType res_ty) + then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= @@ -312,7 +312,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -383,8 +383,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy n -synifyTyLit (StrTyLit s) = HsStrTy s +synifyTyLit (NumTyLit n) = HsNumTy mempty n +synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 416f5d71..5caefa77 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -91,8 +91,8 @@ 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 nwcs) = +filterSigNames _ orig@(MinimalSig _ _) = Just orig +filterSigNames p (TypeSig ns ty nwcs) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty nwcs) @@ -169,14 +169,6 @@ before :: Located a -> Located a -> Bool before = (<) `on` getLoc -instance Foldable (GenLocated l) where - foldMap f (L _ x) = f x - - -instance Traversable (GenLocated l) where - mapM f (L l x) = (return . L l) =<< f x - traverse f (L l x) = L l <$> f x - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -197,7 +189,7 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 98a715a9..9ef3d1b1 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs @@ -335,7 +335,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons - , L _ (ConDeclField ns _ doc) <- flds + , L _ (ConDeclField ns _ doc) <- (unLoc flds) , n <- ns ] -- | Extract function argument docs from inside types. @@ -496,7 +496,7 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEVar (L _ x)) = declWith x - lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t lookupExport (IEThingWith (L _ t) _) = declWith t lookupExport (IEModuleContents (L _ m)) = @@ -553,7 +553,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -745,7 +745,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name @@ -785,7 +785,7 @@ extractDecl name mdl decl InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , ConDeclField { cd_fld_names = ns } <- map unLoc rec + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , n == name ] @@ -818,13 +818,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty - | ResTyGADT ty <- con_res con = ty + | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7f69b91e..ee9f8fc4 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -250,10 +250,10 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc (UserTyVar n)) = do { n' <- rename n ; return (L loc (UserTyVar n')) } -renameLTyVarBndr (L loc (KindedTyVar n kind)) +renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar n' kind')) } + ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do @@ -330,9 +330,9 @@ renameTyClD d = case d of where renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) + xs' <- mapM rename (map unLoc xs) + ys' <- mapM rename (map unLoc ys) + return (L loc (map noLoc xs', map noLoc ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig @@ -377,9 +377,9 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_details = details', con_res = restype', con_doc = mbldoc' }) where - renameDetails (RecCon fields) = do + renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecCon fields') + return (RecCon (L l fields')) renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a @@ -387,7 +387,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) @@ -414,7 +414,7 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig s -> MinimalSig <$> traverse renameL s + MinimalSig src s -> MinimalSig src <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 9a821b2e..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -154,8 +154,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] case con_details d of PrefixCon _ -> Just d RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) }) + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_details = 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 -- cgit v1.2.3 From 71170fc77962f10d7d001e3b8bc8b92bfeda99bc Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 16 Mar 2015 04:31:13 -0400 Subject: Prevent Synopsis from using up too much horizontal space When long type signatures occur in the Synopsis, the element is stretched beyond the width of the window. Scrollbars don't appear, so it's impossible to read anything when this happens. --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index f762e832..ef652a21 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -318,6 +318,7 @@ div#style-menu-holder { height: 80%; top: 10%; padding: 0; + max-width: 75%; } #synopsis .caption { -- cgit v1.2.3 From 0fc494f2015b7d9cc2cd80e87d67c430e9842777 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 17 Mar 2015 21:59:39 +0000 Subject: Update changelog Closes #151 due to 71170fc77962f10d7d001e3b8bc8b92bfeda99bc --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index d98f7e1e..c988423d 100644 --- a/CHANGES +++ b/CHANGES @@ -30,6 +30,8 @@ Changes in version 2.16.0 * Fix code blocks in presence of Windows line endings + * Deal better with long synopsis lines (#151) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) -- cgit v1.2.3 From fdcd1907a358ef274b687e31118277d2487c60e9 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 25 Feb 2015 02:01:08 -0500 Subject: Make the error encountered when a package can't be found more user-friendly Closes #369 --- haddock-api/src/Haddock.hs | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 72c544e1..3e58aba3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -39,6 +39,7 @@ import Haddock.Options import Haddock.Utils import Control.Monad hiding (forM_) +import Control.Applicative import Data.Foldable (forM_) import Data.List (isPrefixOf) import Control.Exception @@ -250,9 +251,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod + pkgKey = modulePackageKey pkgMod pkgStr = Just (packageKeyString pkgKey) - (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity @@ -288,12 +289,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] - = title - | otherwise = unpackFS pkgNameFS - where PackageName pkgNameFS = pkgName - ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces - odir + case pkgNameVer of + Nothing -> putStrLn . unlines $ + [ "haddock: Unable to find a package providing module " + ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." + , "" + , " Perhaps try specifying the desired package explicitly" + ++ " using the --package-name" + , " and --package-version arguments." + ] + Just (PackageName pkgNameFS, pkgVer) -> + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style @@ -312,12 +321,12 @@ modulePackageInfo :: DynFlags -- contain the package name or version -- provided by the user which we -- prioritise - -> Module -> (PackageName, Data.Version.Version) + -> Module -> Maybe (PackageName, Data.Version.Version) modulePackageInfo dflags flags modu = - (fromMaybe (packageName pkg) (optPackageName flags), - fromMaybe (packageVersion pkg) (optPackageVersion flags)) + cmdline <|> pkgDb where - pkg = getPackageDetails dflags (modulePackageKey modu) + cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags + pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu) ------------------------------------------------------------------------------- -- cgit v1.2.3 From 10437c8cfe3524eee7e1cc297cd6ae7dff16dbb3 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 26 Mar 2015 16:31:40 +0000 Subject: Remove now redundant imports --- haddock-api/src/Haddock/Backends/Xhtml.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 -- haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 -- haddock-api/src/Haddock/GhcUtils.hs | 1 - haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 - haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 1 - haddock-api/src/Haddock/InterfaceFile.hs | 1 - 8 files changed, 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 65a7e6c4..948ef641 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,7 +36,6 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) import Data.Maybe import System.FilePath hiding ( () ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 405a13f8..952d29c9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,7 +27,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 96d734eb..e807eb94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Control.Applicative ((<$>)) - import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 79b093ec..10d6ab10 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes ( import Haddock.Options -import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) @@ -206,4 +205,3 @@ liftEither f = either Left (Right . f) concatEither :: [Either a [b]] -> Either a [b] concatEither = liftEither concat . sequenceEither - diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5caefa77..ce4ca38a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,7 +16,6 @@ module Haddock.GhcUtils where -import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Function diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 35abf8a6..614e606b 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index d92e8b2a..e7d2a085 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Applicative ((<$>)) import Control.Monad (mplus) import Data.Char import DynFlags diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b0df5491..4b39d315 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -25,7 +25,6 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array -import Data.Functor ((<$>)) import Data.IORef import Data.List import qualified Data.Map as Map -- cgit v1.2.3 From f42970cc6d62a63529874bf7dfe0f6e3c010dd13 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 26 Mar 2015 16:45:52 +0000 Subject: Update test to account for \r filtering --- haddock-library/test/Documentation/Haddock/ParserSpec.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 44ec2988..9161160d 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Documentation.Haddock.ParserSpec (main, spec) where @@ -55,8 +56,10 @@ spec = do it "accepts hexadecimal character references" $ do "e" `shouldParseTo` "e" - it "allows to backslash-escape characters" $ do - property $ \x -> ['\\', x] `shouldParseTo` DocString [x] + it "allows to backslash-escape characters except \\r" $ do + property $ \case + '\r' -> "\\\r" `shouldParseTo` DocString "\\" + x -> ['\\', x] `shouldParseTo` DocString [x] context "when parsing strings contaning numeric character references" $ do it "will implicitly convert digits to characters" $ do -- cgit v1.2.3 From 7d8ece225e5387d0d08a675bda82bd2a1af5a173 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 26 Mar 2015 19:29:25 +0000 Subject: Test for anchor defaulting I delete the old tests because it turns out that: * test runner would never put them in scope of each other even with imports so just one would suffice * test runner actually needed some hacking to keep links so in the end we would end up with no anchors making them useless --- html-test/ref/Bug253.html | 99 ++++++++++++++++++++++++++++++++++++ html-test/ref/Ticket253_1.html | 91 --------------------------------- html-test/ref/Ticket253_2.html | 111 ----------------------------------------- html-test/run.lhs | 24 ++++++--- html-test/src/Bug253.hs | 10 ++++ html-test/src/Ticket253_1.hs | 6 --- html-test/src/Ticket253_2.hs | 6 --- 7 files changed, 126 insertions(+), 221 deletions(-) create mode 100644 html-test/ref/Bug253.html delete mode 100644 html-test/ref/Ticket253_1.html delete mode 100644 html-test/ref/Ticket253_2.html create mode 100644 html-test/src/Bug253.hs delete mode 100644 html-test/src/Ticket253_1.hs delete mode 100644 html-test/src/Ticket253_2.hs diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html new file mode 100644 index 00000000..0802d91e --- /dev/null +++ b/html-test/ref/Bug253.html @@ -0,0 +1,99 @@ + +Bug253
    Safe HaskellSafe

    Bug253

    Description

    This module tests that if we're trying to link to a qualified + identifier that's not in scope, we get an anchor as if it was a + variable. Previous behaviour was to treat it as a type constructor + so issue like #253 arose. Also see rename function comments in + source.

    Synopsis

    Documentation

    foo :: ()

    This link should generate #v anchor: fakeFakeFake

    diff --git a/html-test/ref/Ticket253_1.html b/html-test/ref/Ticket253_1.html deleted file mode 100644 index ade128e9..00000000 --- a/html-test/ref/Ticket253_1.html +++ /dev/null @@ -1,91 +0,0 @@ - -Ticket253_1
    Safe HaskellSafe

    Ticket253_1

    Synopsis

    Documentation

    foo :: Int

    See bar.

    Also see Baz

    diff --git a/html-test/ref/Ticket253_2.html b/html-test/ref/Ticket253_2.html deleted file mode 100644 index 0b03a874..00000000 --- a/html-test/ref/Ticket253_2.html +++ /dev/null @@ -1,111 +0,0 @@ - -Ticket253_2
    Safe HaskellSafe

    Ticket253_2

    Synopsis

    Documentation

    bar :: Int

    Comment

    data Baz

    Constructors

    Baz 
    diff --git a/html-test/run.lhs b/html-test/run.lhs index a80b265e..1f19b723 100755 --- a/html-test/run.lhs +++ b/html-test/run.lhs @@ -21,7 +21,6 @@ import System.Exit import System.FilePath import System.Process (ProcessHandle, runProcess, waitForProcess, system) - packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath baseDir = takeDirectory __FILE__ testDir = baseDir "src" @@ -112,11 +111,11 @@ check modules strict = do then do out <- readFile outfile ref <- readFile reffile - if not $ haddockEq out ref + if not $ haddockEq (outfile, out) (reffile, ref) then do putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:" - let ref' = stripLinks ref - out' = stripLinks out + let ref' = maybeStripLinks outfile ref + out' = maybeStripLinks reffile out let reffile' = outDir takeFileName reffile ++ ".nolinks" outfile' = outDir takeFileName outfile ++ ".ref.nolinks" writeFile reffile' ref' @@ -134,6 +133,10 @@ check modules strict = do else do putStrLn $ "Pass: " ++ mod ++ " (no .ref file)" +-- | List of modules in which we don't 'stripLinks' +preserveLinksModules :: [String] +preserveLinksModules = map (++ ".html") ["Bug253"] + -- | A rather nasty way to drop the Haddock version string from the -- end of the generated HTML files so that we don't have to change -- every single test every time we change versions. We rely on the the @@ -146,9 +149,16 @@ dropVersion = reverse . dropTillP . reverse dropTillP ('p':'<':xs) = xs dropTillP (_:xs) = dropTillP xs -haddockEq :: String -> String -> Bool -haddockEq file1 file2 = - stripLinks (dropVersion file1) == stripLinks (dropVersion file2) +haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool +haddockEq (fn1, file1) (fn2, file2) = + maybeStripLinks fn1 (dropVersion file1) + == maybeStripLinks fn2 (dropVersion file2) + +maybeStripLinks :: String -- ^ Module we're considering for stripping + -> String -> String +maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules + then id + else stripLinks stripLinks :: String -> String stripLinks str = diff --git a/html-test/src/Bug253.hs b/html-test/src/Bug253.hs new file mode 100644 index 00000000..499f6cd4 --- /dev/null +++ b/html-test/src/Bug253.hs @@ -0,0 +1,10 @@ +-- | This module tests that if we're trying to link to a /qualified/ +-- identifier that's not in scope, we get an anchor as if it was a +-- variable. Previous behaviour was to treat it as a type constructor +-- so issue like #253 arose. Also see @rename@ function comments in +-- source. +module Bug253 where + +-- | This link should generate @#v@ anchor: 'DoesNotExist.fakeFakeFake' +foo :: () +foo = () diff --git a/html-test/src/Ticket253_1.hs b/html-test/src/Ticket253_1.hs deleted file mode 100644 index 62ab4b17..00000000 --- a/html-test/src/Ticket253_1.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Ticket253_1 where --- | See 'Ticket253_2.bar'. --- --- Also see 'Ticket253_2.Baz' -foo :: Int -foo = 0 diff --git a/html-test/src/Ticket253_2.hs b/html-test/src/Ticket253_2.hs deleted file mode 100644 index a19d4cee..00000000 --- a/html-test/src/Ticket253_2.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Ticket253_2 where --- | Comment -bar :: Int -bar = 0 - -data Baz = Baz -- cgit v1.2.3 From 6dee5e814d1934cbed458894e01b4913452422e6 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 00:05:58 +0000 Subject: Clearly default to variables in out of scope case --- CHANGES | 3 ++ haddock-api/src/Haddock/Interface/LexParseRn.hs | 63 ++++++++++++++++--------- 2 files changed, 43 insertions(+), 23 deletions(-) diff --git a/CHANGES b/CHANGES index c988423d..419a7be7 100644 --- a/CHANGES +++ b/CHANGES @@ -32,6 +32,9 @@ Changes in version 2.16.0 * Deal better with long synopsis lines (#151) + * Don't default to type constructors for out-of-scope names (#253 and + #375) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 614e606b..14826eaa 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -30,6 +30,7 @@ import Haddock.Types import Name import Outputable (showPpr) import RdrName +import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (MDoc Name) @@ -73,7 +74,13 @@ processModuleHeader dflags gre safety mayStr = do where failure = (emptyHaddockModInfo, Nothing) - +-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the +-- definitions and a parsed comment and we attempt to make sense of +-- where the identifiers in the comment point to. We're in effect +-- trying to convert 'RdrName's to 'Name's, with some guesswork and +-- fallbacks in case we can't locate the identifiers. +-- +-- See the comments in the source for implementation commentary. rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name rename dflags gre = rn where @@ -81,19 +88,36 @@ rename dflags gre = rn DocAppend a b -> DocAppend (rn a) (rn b) DocParagraph doc -> DocParagraph (rn doc) DocIdentifier x -> do - let choices = dataTcOccs' x + -- 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 + -- We found no names in the env so we start guessing. [] -> case choices of [] -> DocMonospaced (DocString (showPpr dflags x)) - [a] -> outOfScope dflags a - a:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b + -- There was nothing in the environment so we need to + -- pick some default from what's available to us. We + -- diverge here from the old way where we would default + -- to type constructors as we're much more likely to + -- actually want anchors to regular definitions than + -- type constructor names (such as in #253). So now we + -- only get type constructor links if they are actually + -- in scope. + a:_ -> outOfScope dflags a + + -- There is only one name in the environment that matches so + -- use it. [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. + -- But when there are multiple names available, default to + -- type constructors: somewhat awfully GHC returns the + -- values in the list positionally. + a:b:_ | isTyConName a -> DocIdentifier a + | otherwise -> DocIdentifier b DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) @@ -114,21 +138,14 @@ rename dflags gre = rn DocString str -> DocString str DocHeader (Header l t) -> DocHeader $ Header l (rn t) -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - +-- | Wrap an identifier that's out of scope (i.e. wasn't found in +-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently +-- we simply monospace the identifier in most cases except when the +-- identifier is qualified: if the identifier is qualified then we can +-- still try to guess and generate anchors accross modules but the +-- users shouldn't rely on this doing the right thing. See tickets +-- #253 and #375 on the confusion this causes depending on which +-- default we pick in 'rename'. outOfScope :: DynFlags -> RdrName -> Doc a outOfScope dflags x = case x of -- cgit v1.2.3 From bb0ecbb4053a593cc8ef80a277c4ef40b13998d5 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 01:14:11 +0000 Subject: Fix Hoogle display of constructors Fixes #361 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index 419a7be7..15ab0a24 100644 --- a/CHANGES +++ b/CHANGES @@ -35,6 +35,8 @@ Changes in version 2.16.0 * Don't default to type constructors for out-of-scope names (#253 and #375) + * Fix Hoogle display of constructors (#361) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index fe656a4b..ef86958e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -198,7 +198,10 @@ ppCtor dflags dat subdocs con apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ map unL $ con_names con + + -- We print the constructors as comma-separated list. See GHC + -- docs for con_names on why it is a list to begin with. + name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ -- cgit v1.2.3 From fdc4e8a1cafdb5accb8cef05c60579df9d438fd7 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 01:45:18 +0000 Subject: Fully qualify names in Hoogle instances output Closes #263 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ef86958e..3ffa582f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -95,13 +95,15 @@ dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr +outWith :: Outputable a => (SDoc -> String) -> a -> [Char] +outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where f xs | " " `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs f [] = [] +out :: Outputable a => DynFlags -> a -> String +out dflags = outWith $ showSDocUnqual dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" @@ -156,8 +158,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] - +ppInstance dflags x = + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x] ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] -- cgit v1.2.3 From 4999f090864463aec6cbcf4f3319015b6601ccef Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 01:55:01 +0000 Subject: Update changelog --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index 15ab0a24..f436cf64 100644 --- a/CHANGES +++ b/CHANGES @@ -37,6 +37,8 @@ Changes in version 2.16.0 * Fix Hoogle display of constructors (#361) + * Fully qualify names in Hoogle instances output (#263) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) -- cgit v1.2.3 From 1a65ec54ce8516dc2d09af3b1d20fedd21e64ad6 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 02:43:55 +0000 Subject: Output method documentation in Hoogle backend One thing of note is that we no longer preserve grouping of methods and print each method on its own line. We could preserve it if no documentation is present for any methods in the group if someone asks for it though. Fixes #259 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 32 ++++++++++++++++++++---------- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/CHANGES b/CHANGES index f436cf64..7aba49ae 100644 --- a/CHANGES +++ b/CHANGES @@ -39,6 +39,8 @@ Changes in version 2.16.0 * Fully qualify names in Hoogle instances output (#263) + * Output method documentation in Hoogle backend (#259) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 3ffa582f..12dfc1f5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -109,6 +109,8 @@ operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x +commaSeparate :: Outputable a => DynFlags -> [a] -> String +commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -121,30 +123,38 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] - -ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] +ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc dflags (TypeSig names sig _) subdocs + = concatMap mkDocSig names where - prettyNames = intercalate ", " $ map (out dflags) names + mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) + ++ [mkSig n] + mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + + getDoc :: Located Name -> [Documentation Name] + getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) + typ = case unL sig of HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d x -> x -ppSig _ _ = [] +ppSigWithDoc _ _ _ = [] + +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : + concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -203,7 +213,7 @@ ppCtor dflags dat subdocs con -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con + name = commaSeparate dflags . map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ -- cgit v1.2.3 From e49d473bf33fa374c60462ad178ac539f026c3ff Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 03:04:21 +0000 Subject: Don't print instance safety information in Hoogle Fixes #168 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 13 +++++++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/CHANGES b/CHANGES index 7aba49ae..af90b4fc 100644 --- a/CHANGES +++ b/CHANGES @@ -41,6 +41,8 @@ Changes in version 2.16.0 * Output method documentation in Hoogle backend (#259) + * Don't print instance safety information in Hoogle (#168) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 12dfc1f5..914e3466 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,7 +15,8 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where - +import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) @@ -169,7 +170,15 @@ ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x] + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] -- cgit v1.2.3 From b44763d0c429d2acce731ea33ed4d5feec7a85a9 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 28 Mar 2015 00:11:47 +0000 Subject: Post-release version bumps and changelog --- CHANGES | 25 ++++++++++++++----------- haddock-api/haddock-api.cabal | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 4 files changed, 17 insertions(+), 14 deletions(-) diff --git a/CHANGES b/CHANGES index af90b4fc..19639ef1 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,17 @@ +Changes in version 2.16.1 + + * Don't default to type constructors for out-of-scope names (#253 and + #375) + + * Fix Hoogle display of constructors (#361) + + * Fully qualify names in Hoogle instances output (#263) + + * Output method documentation in Hoogle backend (#259) + + * Don't print instance safety information in Hoogle (#168) + + Changes in version 2.16.0 * Experimental collapsible header support (#335) @@ -32,17 +46,6 @@ Changes in version 2.16.0 * Deal better with long synopsis lines (#151) - * Don't default to type constructors for out-of-scope names (#253 and - #375) - - * Fix Hoogle display of constructors (#361) - - * Fully qualify names in Hoogle instances output (#263) - - * Output method documentation in Hoogle backend (#259) - - * Don't print instance safety information in Hoogle (#168) - Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 22b3ae57..7ab7d71d 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,5 +1,5 @@ name: haddock-api -version: 2.16.0 +version: 2.16.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b0f886cd..3d9b7557 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,5 +1,5 @@ name: haddock-library -version: 1.2.0 +version: 1.2.1 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell libraries. These modules expose some functionality of it diff --git a/haddock.cabal b/haddock.cabal index fbb4bfed..ce743d94 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.16.0 +version: 2.16.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries -- cgit v1.2.3 From 8ba7777c5db203512263934dfe40d56c1b4199b8 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 28 Mar 2015 20:07:15 +0000 Subject: Loosen bounds on haddock-* --- haddock-api/haddock-api.cabal | 2 +- haddock.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 7ab7d71d..3bc22263 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -48,7 +48,7 @@ library , ghc >= 7.10 && < 7.10.2 , ghc-paths - , haddock-library == 1.2.0.* + , haddock-library == 1.2.* hs-source-dirs: src diff --git a/haddock.cabal b/haddock.cabal index ce743d94..03bb28ab 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -110,7 +110,7 @@ executable haddock Haddock.GhcUtils Haddock.Convert else - build-depends: haddock-api == 2.16.0 + build-depends: haddock-api == 2.16.* test-suite html-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From d567a12b2d24bab610cd7e8f8014d40c7615e24d Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 28 Mar 2015 20:38:10 +0000 Subject: Expand response files in arguments Closes #285 --- CHANGES | 1 + driver/Main.hs | 28 +++++++++++++++++++++++++--- 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/CHANGES b/CHANGES index 19639ef1..e170bc46 100644 --- a/CHANGES +++ b/CHANGES @@ -11,6 +11,7 @@ Changes in version 2.16.1 * Don't print instance safety information in Hoogle (#168) + * Expand response files in arguments (#285) Changes in version 2.16.0 diff --git a/driver/Main.hs b/driver/Main.hs index 42b99860..5097a86d 100644 --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,7 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Documentation.Haddock (haddock) -import System.Environment (getArgs) +import Control.Exception +import Documentation.Haddock (haddock) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO main :: IO () -main = getArgs >>= haddock +main = getArgs >>= expandResponse >>= haddock + + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. The contents will be passed through 'words' +-- and blanks filtered out first. +-- +-- We quit if the file is not found or reading somehow fails. +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . filter (not . null) . words + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure -- cgit v1.2.3 From 5d04e313cc52ecf88b0fd0b3d0d39ce6a8dc7406 Mon Sep 17 00:00:00 2001 From: watashi Date: Sun, 26 Apr 2015 16:35:28 -0700 Subject: Do not insert anchor for section headings in contents box --- .gitignore | 3 + .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 5 +- html-test/ref/Bug387.html | 111 +++++++++++++++++++++ html-test/src/Bug387.hs | 12 +++ 4 files changed, 130 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Bug387.html create mode 100644 html-test/src/Bug387.hs diff --git a/.gitignore b/.gitignore index 6b8d26e0..2d3f4516 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,6 @@ /doc/configure tags TAGS + +.cabal-sandbox +cabal.sandbox.config diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index e807eb94..c23f3f08 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -62,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup { then anchor ! [href url] << fromMaybe url mLabel else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", + markupAName = \aname + -> if insertAnchors + then namedAnchor aname << "" + else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml, diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html new file mode 100644 index 00000000..2d2009b1 --- /dev/null +++ b/html-test/ref/Bug387.html @@ -0,0 +1,111 @@ + +Bug387
    Safe HaskellSafe

    Bug387

    Synopsis

    Section1

    test1 :: Int

    Section2

    test2 :: Int

    diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs new file mode 100644 index 00000000..d9fed34e --- /dev/null +++ b/html-test/src/Bug387.hs @@ -0,0 +1,12 @@ +module Bug387 + ( -- * Section1#a:section1# + test1 + -- * Section2#a:section2# + , test2 + ) where + +test1 :: Int +test1 = 223 + +test2 :: Int +test2 = 42 -- cgit v1.2.3 From 319bf20d44589545e6850db3e676e30216dd3cc2 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 6 May 2015 14:55:21 -0400 Subject: Ignore doc/haddock.{ps,pdf} --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 2d3f4516..f07c758d 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,8 @@ /latex-test/out/ /doc/haddock +/doc/haddock.ps +/doc/haddock.pdf /doc/autom4te.cache/ /doc/config.log /doc/config.mk -- cgit v1.2.3 From bf31846b9f7280b5e75f09e91ca18c4ced37af08 Mon Sep 17 00:00:00 2001 From: Murray Campbell Date: Sun, 26 Apr 2015 13:49:01 -0700 Subject: Change ModuleTree Node to carry PackageKey and SourcePackageId to resolve #385 Signed-off-by: Austin Seipp (cherry picked from commit 2380f07c430c525b205ce2eae6dab23c8388d899) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +-- haddock-api/src/Haddock/ModuleTree.hs | 41 +++++++++++++++++-------------- 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 948ef641..90cb9fa4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -288,7 +288,7 @@ mkNodeList qual ss p ts = case ts of mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg short ts) = +mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -312,7 +312,7 @@ mkNode qual ss p (Node s leaf pkg short ts) = mdl = intercalate "." (reverse (s:ss)) shortDescr = maybe noHtml (origDocToHtml qual) short - htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index eec1342e..2f731214 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,41 +15,44 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) | otherwise = Nothing - fn (mod_,pkg,short) = addToTrees mod_ pkg short - - -addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) + | otherwise = Nothing + fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + + +addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ ts = ts +addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short +addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg + this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] +mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ = [] +mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] +mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] splitModule :: Module -> [String] -- cgit v1.2.3 From 3fee88b2891683eeb56db3d7b79e890070530c8f Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Sun, 10 May 2015 13:05:51 +0200 Subject: haddock-library: require GHC >= 7.4 `Data.Monoid.<>` was added in base-4.5/GHC-7.4 Closes #394 Signed-off-by: Mateusz Kowalczyk --- haddock-library/haddock-library.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 3d9b7557..c2ea73b0 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,7 +21,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.5 && < 4.9 , bytestring , transformers , deepseq -- cgit v1.2.3 From 45df734c8e0242ca2e88fba5359207e49d7bf158 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 25 May 2015 17:14:01 +0200 Subject: ApiAnnotations : strings in warnings do not return SourceText The strings used in a WARNING pragma are captured via strings :: { Located ([AddAnn],[Located FastString]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } .. The STRING token has a method getSTRINGs that returns the original source text for a string. A warning of the form {-# WARNING Logic , mkSolver , mkSimpleSolver , mkSolverForLogic , solverSetParams , solverPush , solverPop , solverReset , solverGetNumScopes , solverAssertCnstr , solverAssertAndTrack , solverCheck , solverCheckAndGetModel , solverGetReasonUnknown "New Z3 API support is still incomplete and fragile: \ \you may experience segmentation faults!" #-} returns the concatenated warning string rather than the original source. --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9ef3d1b1..5adaef69 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -158,7 +158,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - ideclPkgQual impDecl) + fmap snd $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From 39a7a1b9e344bfa3258a6414e75f19c1eabc30de Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 27 May 2015 11:51:31 +0200 Subject: Create simple method for indentation parsing. --- haddock-library/src/Documentation/Haddock/Parser.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 5c607a1a..6bb88035 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -382,6 +382,15 @@ takeNonEmptyLine :: Parser String takeNonEmptyLine = do (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n" +-- | Takes indentation of first non-empty line. +-- +-- More precisely: skips all whitespace-only lines and returns indentation +-- (horizontal space, might be empty) of that non-empty line. +takeIndent :: Parser BS.ByteString +takeIndent = do + indent <- takeHorizontalSpace + "\n" *> takeIndent <|> return indent + -- | Blocks of text of the form: -- -- >> foo -- cgit v1.2.3 From 76497980a6746be8bbcfa45341c261ffb68ecd81 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 27 May 2015 21:36:13 +0200 Subject: Make nested lists count indentation according to first item. --- .../src/Documentation/Haddock/Parser.hs | 81 ++++++++++++---------- 1 file changed, 46 insertions(+), 35 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 6bb88035..ca9e9d8d 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -231,18 +231,20 @@ markdownImage = fromHyperlink <$> ("!" *> linkParser) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) -paragraph = examples <|> skipSpace *> ( - since - <|> unorderedList - <|> orderedList - <|> birdtracks - <|> codeblock - <|> property - <|> header - <|> textParagraphThatStartsWithMarkdownLink - <|> definitionList - <|> docParagraph <$> textParagraph - ) +paragraph = examples <|> do + indent <- takeIndent + choice + [ since + , unorderedList indent + , orderedList indent + , birdtracks + , codeblock + , property + , header + , textParagraphThatStartsWithMarkdownLink + , definitionList indent + , docParagraph <$> textParagraph + ] since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty @@ -283,16 +285,16 @@ textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdo | otherwise = " " -- | Parses unordered (bullet) lists. -unorderedList :: Parser (DocH mod Identifier) -unorderedList = DocUnorderedList <$> p +unorderedList :: BS.ByteString -> Parser (DocH mod Identifier) +unorderedList indent = DocUnorderedList <$> p where - p = ("*" <|> "-") *> innerList p + p = ("*" <|> "-") *> innerList indent p -- | Parses ordered lists (numbered or dashed). -orderedList :: Parser (DocH mod Identifier) -orderedList = DocOrderedList <$> p +orderedList :: BS.ByteString -> Parser (DocH mod Identifier) +orderedList indent = DocOrderedList <$> p where - p = (paren <|> dot) *> innerList p + p = (paren <|> dot) *> innerList indent p dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" @@ -301,23 +303,24 @@ orderedList = DocOrderedList <$> p -- same paragraph. Usually used as -- -- > someListFunction = listBeginning *> innerList someListFunction -innerList :: Parser [DocH mod Identifier] -> Parser [DocH mod Identifier] -innerList item = do +innerList :: BS.ByteString -> Parser [DocH mod Identifier] + -> Parser [DocH mod Identifier] +innerList indent item = do c <- takeLine - (cs, items) <- more item + (cs, items) <- more indent item let contents = docParagraph . parseString . dropNLs . unlines $ c : cs return $ case items of Left p -> [contents `docAppend` p] Right i -> contents : i -- | Parses definition lists. -definitionList :: Parser (DocH mod Identifier) -definitionList = DocDefList <$> p +definitionList :: BS.ByteString -> Parser (DocH mod Identifier) +definitionList indent = DocDefList <$> p where p = do label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` ("]\n" :: String))) <* ("]" <* optional ":") c <- takeLine - (cs, items) <- more p + (cs, items) <- more indent p let contents = parseString . dropNLs . unlines $ c : cs return $ case items of Left x -> [(label, contents `docAppend` x)] @@ -330,32 +333,40 @@ dropNLs = reverse . dropWhile (== '\n') . reverse -- | Main worker for 'innerList' and 'definitionList'. -- We need the 'Either' here to be able to tell in the respective functions -- whether we're dealing with the next list or a nested paragraph. -more :: Monoid a => Parser a +more :: Monoid a => BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -more item = innerParagraphs <|> moreListItems item - <|> moreContent item <|> pure ([], Right mempty) +more indent item = innerParagraphs indent + <|> moreListItems indent item + <|> moreContent indent item + <|> pure ([], Right mempty) -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs. -innerParagraphs :: Parser ([String], Either (DocH mod Identifier) a) -innerParagraphs = (,) [] . Left <$> ("\n" *> indentedParagraphs) +innerParagraphs :: BS.ByteString + -> Parser ([String], Either (DocH mod Identifier) a) +innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent) -- | Attempts to fetch the next list if possibly. Used by 'innerList' and -- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph. -moreListItems :: Parser a +moreListItems :: BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -moreListItems item = (,) [] . Right <$> (skipSpace *> item) +moreListItems indent item = (,) [] . Right <$> indentedItem + where + indentedItem = string indent *> skipSpace *> item -- | Helper for 'innerList' and 'definitionList' which simply takes -- a line of text and attempts to parse more list content with 'more'. -moreContent :: Monoid a => Parser a +moreContent :: Monoid a => BS.ByteString -> Parser a -> Parser ([String], Either (DocH mod Identifier) a) -moreContent item = first . (:) <$> nonEmptyLine <*> more item +moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item -- | Parses an indented paragraph. -- The indentation is 4 spaces. -indentedParagraphs :: Parser (DocH mod Identifier) -indentedParagraphs = (concat <$> dropFrontOfPara " ") >>= parseParagraphs +indentedParagraphs :: BS.ByteString -> Parser (DocH mod Identifier) +indentedParagraphs indent = + (concat <$> dropFrontOfPara indent') >>= parseParagraphs + where + indent' = string $ BS.append indent " " -- | Grab as many fully indented paragraphs as we can. dropFrontOfPara :: Parser BS.ByteString -> Parser [String] -- cgit v1.2.3 From c4a73b5b0fb7574bd519584c16b5be0675f3f430 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 27 May 2015 22:46:13 +0200 Subject: Add simple test case for arbitrary-depth list nesting. --- html-test/ref/Nesting.html | 49 ++++++++++++++++++++++++++++++++++++---------- html-test/src/Nesting.hs | 15 ++++++++++++++ 2 files changed, 54 insertions(+), 10 deletions(-) diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html index 37ee7af3..542d6db7 100644 --- a/html-test/ref/Nesting.html +++ b/html-test/ref/Nesting.html @@ -73,6 +73,10 @@ window.onload = function () {pageLoad();setSynopsis("mini_Nesting.html");}; >j :: t
  • k :: t
    • No newline separation even in indented lists. We can have any paragraph level element that we normally - can, like headers

    Level 3 header

    with some content…

    • and even more lists inside

    Level 3 header

    with some content…

    • and even more lists inside

    k :: t

    • list may start at arbitrary depth
    • and consecutive items at that depth + belong to the same list

    • of course we can still

      • nest items like we are used to
    • and then get back to initial list
    Date: Wed, 3 Jun 2015 02:11:31 +0200 Subject: Add arbitrary-indent spec test for parser. --- .../test/Documentation/Haddock/ParserSpec.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 9161160d..2ef414fb 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -696,6 +696,23 @@ spec = do ] <> DocOrderedList [ DocParagraph "baz" ] + it "allows arbitrary initial indent of a list" $ do + unlines + [ " * foo" + , " * bar" + , "" + , " * quux" + , "" + , " * baz" + ] + `shouldParseTo` + DocUnorderedList + [ DocParagraph "foo" + , DocParagraph "bar" + <> DocUnorderedList [ DocParagraph "quux" ] + , DocParagraph "baz" + ] + it "definition lists can come back to top level with a different list" $ do "[foo]: foov\n\n [bar]: barv\n\n1. baz" `shouldParseTo` DocDefList [ ("foo", "foov" -- cgit v1.2.3 From 194f382f84a401a82464438820f074aa7851b725 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Wed, 3 Jun 2015 05:25:29 +0100 Subject: Update docs with info on new list nesting rule Fixes #278 through commits from PR #401 --- doc/haddock.xml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/haddock.xml b/doc/haddock.xml index 2ffd7d78..f6cd4d4d 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -2029,7 +2029,18 @@ This belongs to the list above! 2. No newline separation even in indented lists. -} + The indentation of the first list item is honoured. That is, + in the following example the items are on the same level. Before + Haddock 2.16.1, the second item would have been nested under the + first item which was unexpected. + + +{-| + * foo + * bar +-} +
    -- cgit v1.2.3 From d50967d6a20ec43b048b69122590b410ea872dc4 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Wed, 3 Jun 2015 05:29:26 +0100 Subject: Update some meta data at the top of the docs --- doc/haddock.xml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/doc/haddock.xml b/doc/haddock.xml index f6cd4d4d..b528fdb5 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -12,7 +12,7 @@ - 2004-08-02 + 2015-06-02 Haddock User Guide Simon @@ -24,12 +24,21 @@ Waern
    david.waern@gmail.com
    + + Mateusz + Kowalczyk + +
    fuuzetsu@fuuzetsu.co.uk
    2010 Simon Marlow, David Waern + + 2013-2015 + Mateusz Kowalczyk + - This document describes Haddock version 2.15.1, a Haskell + This document describes Haddock version 2.16.1, a Haskell documentation tool.     -- cgit v1.2.3 From fb5d8584779da51521e8bf745e8627b5ddf3724d Mon Sep 17 00:00:00 2001 From: Bartosz Nitka Date: Sun, 7 Jun 2015 08:40:59 -0700 Subject: Add some Hacking docs for getting started --- README.md | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/README.md b/README.md index b85d99b7..fba02bde 100644 --- a/README.md +++ b/README.md @@ -45,3 +45,22 @@ format. #### Contributing Please create issues when you have any problems and pull requests if you have some code. + +###### Hacking + +To get started you'll need a latest GHC release installed. + + git clone https://github.com/haskell/haddock.git + cd haddock + cabal sandbox init + cabal sandbox add-source haddock-library + cabal sandbox add-source haddock-api + # adjust -j to the number of cores you want to use + cabal install -j4 --dependencies-only --enable-tests + cabal configure --enable-tests + cabal build -j4 + # run the test suite + cabal test + +If you want to build against `GHC HEAD`, `ghc-head` is the corresponding branch. +Note that it doesn't have to be up to date. -- cgit v1.2.3 From 2d1b63e9f01b0a926ef4f8ca8de800bc8a4f27cc Mon Sep 17 00:00:00 2001 From: Bartosz Nitka Date: Sun, 7 Jun 2015 08:44:30 -0700 Subject: Fix markdown --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index fba02bde..f6dd00d4 100644 --- a/README.md +++ b/README.md @@ -50,6 +50,7 @@ Please create issues when you have any problems and pull requests if you have so To get started you'll need a latest GHC release installed. +```bash git clone https://github.com/haskell/haddock.git cd haddock cabal sandbox init @@ -61,6 +62,7 @@ To get started you'll need a latest GHC release installed. cabal build -j4 # run the test suite cabal test +``` If you want to build against `GHC HEAD`, `ghc-head` is the corresponding branch. Note that it doesn't have to be up to date. -- cgit v1.2.3 From a65953de929fd9488250f8e0257c918465193e43 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Mon, 8 Jun 2015 15:08:36 +0100 Subject: Refine hacking instructions slightly --- README.md | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index f6dd00d4..31015e91 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,8 @@ Please create issues when you have any problems and pull requests if you have so ###### Hacking -To get started you'll need a latest GHC release installed. +To get started you'll need a latest GHC release installed. Below is an +example setup using cabal sandboxes. ```bash git clone https://github.com/haskell/haddock.git @@ -64,5 +65,8 @@ To get started you'll need a latest GHC release installed. cabal test ``` -If you want to build against `GHC HEAD`, `ghc-head` is the corresponding branch. -Note that it doesn't have to be up to date. +If you're a GHC developer and want to update Haddock to work with your +changes, you should be working on `ghc-head` branch instead of master. +See instructions at +https://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/Git/Submodules +for an example workflow. -- cgit v1.2.3 From 553c719236972f3a1d445146352ec94614979b63 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 8 Jun 2015 23:47:28 -0500 Subject: Update after wild card renaming refactoring in D613 Summary: * Move `Post*` type instances to `Haddock.Types` as other modules than `Haddock.Interface.Rename` will rely on these type instances. * Update after wild card renaming refactoring in D613. Reviewers: simonpj, austin Reviewed By: austin Differential Revision: https://phabricator.haskell.org/D954 GHC Trac Issues: #10098 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 12 +++++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 +++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 19 +++++-------------- haddock-api/src/Haddock/Types.hs | 19 ++++++++++++++++++- 4 files changed, 37 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c9262c7e..e1090a0e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -898,9 +898,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -939,9 +941,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 88aa966c..c0be9735 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -852,9 +852,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -899,9 +901,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 56e5b07f..2b50ce9a 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -21,8 +20,6 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import NameSet -import Coercion import Control.Applicative import Control.Monad hiding (mapM) @@ -234,8 +231,7 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) @@ -257,6 +253,10 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className @@ -517,12 +517,3 @@ renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') - -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder - -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e93294a0..847320a7 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -34,6 +34,8 @@ import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) import OccName import Outputable +import NameSet (NameSet) +import Coercion (Coercion) import Control.Applicative (Applicative(..)) import Control.Monad (ap) @@ -551,3 +553,18 @@ instance Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder -- cgit v1.2.3 From 2b467a747df246090d1fd0270ea9bd4192ebe3df Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sat, 23 May 2015 04:56:18 -0700 Subject: Build executable with '-threaded' (fixes #399) --- haddock.cabal | 2 +- html-test/ref/Threaded.html | 94 ++++++++++++++++++++++++++++++++++++++++++++ html-test/src/Threaded.hs | 10 +++++ html-test/src/Threaded_TH.hs | 13 ++++++ 4 files changed, 118 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Threaded.html create mode 100644 html-test/src/Threaded.hs create mode 100644 html-test/src/Threaded_TH.hs diff --git a/haddock.cabal b/haddock.cabal index 03bb28ab..ed570f53 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -42,7 +42,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded build-depends: base >= 4.3 && < 4.9 diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html new file mode 100644 index 00000000..95a18933 --- /dev/null +++ b/html-test/ref/Threaded.html @@ -0,0 +1,94 @@ + +Threaded
    Safe HaskellNone

    Threaded

    Description

    Ensures haddock built with -threaded.

    Synopsis

    Documentation

    f :: Integer

    $(forkTH) fails at compile time if haddock isn't using the + threaded RTS.

    diff --git a/html-test/src/Threaded.hs b/html-test/src/Threaded.hs new file mode 100644 index 00000000..7f3073ad --- /dev/null +++ b/html-test/src/Threaded.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Ensures haddock built with @-threaded@. +module Threaded where + +import Threaded_TH + +-- | @$(forkTH)@ fails at compile time if haddock isn't using the +-- threaded RTS. +f = $(forkTH) diff --git a/html-test/src/Threaded_TH.hs b/html-test/src/Threaded_TH.hs new file mode 100644 index 00000000..53e5a399 --- /dev/null +++ b/html-test/src/Threaded_TH.hs @@ -0,0 +1,13 @@ +-- | Imported by 'Threaded', since a TH splice can't be used in the +-- module where it is defined. +module Threaded_TH where + +import Control.Concurrent (forkOS) +import Language.Haskell.TH.Syntax (Exp (LitE), Lit (IntegerL), Q, runIO) + +-- | forkOS requires the threaded RTS, so this TH fails if haddock was +-- built without @-threaded@. +forkTH :: Q Exp +forkTH = do + _ <- runIO (forkOS (return ())) + return (LitE (IntegerL 0)) -- cgit v1.2.3 From 3d9e8134829c62448d1988813f9565d09be69f30 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 12 Jun 2015 02:59:19 +0100 Subject: Update changelog for -threaded Closes #400 --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index e170bc46..ef3c2f95 100644 --- a/CHANGES +++ b/CHANGES @@ -13,6 +13,8 @@ Changes in version 2.16.1 * Expand response files in arguments (#285) + * Build the main executable with -threaded (#399) + Changes in version 2.16.0 * Experimental collapsible header support (#335) -- cgit v1.2.3 From a7c6a56b1ec1481250b962ecf603a10b0720b1c7 Mon Sep 17 00:00:00 2001 From: Bartosz Nitka Date: Sat, 6 Jun 2015 08:12:18 -0700 Subject: Fix haddock: internal error: spliceURL UnhelpfulSpan (#207) Inferred type signatures don't have SrcSpans, so let's use the one from the declaration. I've tested this manually on the test-case from #207, but I got stuck at trying to run the test-suite. --- haddock-api/src/Haddock/Interface/Create.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9ef3d1b1..7491a01e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -517,7 +517,7 @@ mkExportItems case findDecl t of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -620,13 +620,19 @@ hiDecl dflags t = do O.text "-- Please report this on Haddock issue tracker!" bugWarn = O.showSDoc dflags . warnLine -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc splice fixity = do +-- | This function is called for top-level bindings without type signatures. +-- It gets the type signature from GHC and that means it's not going to +-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the +-- declaration and use it instead - 'nLoc' here. +hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) where + fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -737,7 +743,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) + fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = -- cgit v1.2.3 From 5aaa14fa020da56be7fdf943f6da3310d11a3593 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 12 Jun 2015 03:01:50 +0100 Subject: Changelog for #207 Fixes #207, closes #402 --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index ef3c2f95..adcb6ca5 100644 --- a/CHANGES +++ b/CHANGES @@ -15,6 +15,8 @@ Changes in version 2.16.1 * Build the main executable with -threaded (#399) + * Use SrcSpan of declarations for inferred type sigs (#207) + Changes in version 2.16.0 * Experimental collapsible header support (#335) -- cgit v1.2.3 From 3d11080b9f56a901593b6237d674d617a429e64a Mon Sep 17 00:00:00 2001 From: jpmoresmau Date: Sun, 17 May 2015 15:31:03 +0200 Subject: Attach to instance location the name that has the same location file Fixes #383 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 24 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 23 ++++++++++++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 5 +++-- haddock-api/src/Haddock/Types.hs | 2 +- 6 files changed, 39 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 125e1b3a..2febd5ae 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (L _ i,Nothing) = Just i +isUndocdInstance (i,Nothing,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (L _ instHead, doc) = +ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 952d29c9..df85a492 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -497,12 +497,12 @@ ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppS ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html ppInstances links instances baseName unicode qual - = subInstances qual instName links True baseName (map instDecl instances) + = subInstances qual instName links True (map instDecl instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> (SubDecl,SrcSpan) - instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) + instDecl :: DocInstance DocName -> (SubDecl,Located DocName) + instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 923958a7..e686d648 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId) - import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) @@ -148,20 +147,21 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs + -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html -subTableSrc _ _ _ _ [] = Nothing -subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ [] = Nothing +subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow ((decl, mdoc, subs),loc) = + subRow ((decl, mdoc, subs),L loc dn) = (td ! [theclass "src"] << decl - <+> linkHtml loc + <+> linkHtml loc dn <-> docElement td << fmap (docToHtml Nothing qual) mdoc ) : map (cell . (td <<)) subs - linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn - linkHtml _ = noHtml + linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn + linkHtml _ _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -191,12 +191,12 @@ subEquations qual = divSubDecls "equations" "Equations" . subTable qual -- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> LinksInfo -> Bool -> DocName - -> [(SubDecl,SrcSpan)] -> Html -subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subInstances qual nm lnks splice = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 37203d63..fc530507 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -38,6 +38,7 @@ import MonadUtils (liftIO) import Name import Outputable (text, sep, (<+>)) import PrelNames +import SrcLoc import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon @@ -68,11 +69,11 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc) + let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap @@ -80,14 +81,14 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ] - famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text @@ -106,6 +107,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (clsn,_,_,_) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + -- spanName on Either + spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) + spanNameE s (Right ok) linst = + let L l r = spanName s ok linst + in L l (Right r) instLookup :: (InstalledInterface -> Map.Map Name a) -> Name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ee9f8fc4..1a559764 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -498,10 +498,11 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(L l inst, idoc) -> do + instances' <- forM instances $ \(inst, idoc, L l n) -> do inst' <- renameInstHead inst + n' <- rename n idoc' <- mapM renameDoc idoc - return (L l inst', idoc') + return (inst', idoc',L l n') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index f9cf6e17..14995098 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -300,7 +300,7 @@ instance OutputableBndr a => Outputable (InstType a) where ppr (DataInst a) = text "DataInst" <+> ppr a -- | An instance head that may have documentation and a source location. -type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) +type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type -- cgit v1.2.3 From f48474f640387dca4b42182c1ac78ba30865742d Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 12 Jun 2015 16:08:27 +0100 Subject: Update changelog Closes #398 --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index adcb6ca5..368002dd 100644 --- a/CHANGES +++ b/CHANGES @@ -17,6 +17,8 @@ Changes in version 2.16.1 * Use SrcSpan of declarations for inferred type sigs (#207) + * Fix cross-module instance locations (#383) + Changes in version 2.16.0 * Experimental collapsible header support (#335) -- cgit v1.2.3 From a476b251e363b3b0ed30c75cf72a19fc275d6440 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Fri, 12 Jun 2015 12:59:24 -0400 Subject: Fix alignment of Source links in instance table in Firefox Due to a Firefox bug [1], a combination of 'whitespace: nowrap' on the parent element with 'float: right' on the inner element can cause the floated element to be displaced downwards for no apparent reason. To work around this, the left side is wrapped in its own and set to 'float: left'. As a precautionary measure to prevent the parent element from collapsing entirely, we also add the classic "clearfix" hack. The latter is not strictly needed but it helps prevent bugs if the layout is altered again in the future. Fixes #384. Remark: line 159 of src/Haddock/Backends/Xhtml/Layout.hs was indented to prevent confusion over the operator precedence of (<+>) vs (<<). [1]: https://bugzilla.mozilla.org/show_bug.cgi?id=488725 --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 13 +++++++++++++ haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 5 +++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index ef652a21..1110b407 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -416,6 +416,14 @@ div#style-menu-holder { margin-top: 0.8em; } +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + .subs dl { margin: 0; } @@ -455,6 +463,11 @@ div#style-menu-holder { margin-left: 1em; } +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + .top p.src { border-top: 1px solid #ccc; } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e686d648..914a7a7e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -154,8 +154,9 @@ subTableSrc _ _ _ [] = Nothing subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where subRow ((decl, mdoc, subs),L loc dn) = - (td ! [theclass "src"] << decl - <+> linkHtml loc dn + (td ! [theclass "src clearfix"] << + (thespan ! [theclass "inst-left"] << decl) + <+> linkHtml loc dn <-> docElement td << fmap (docToHtml Nothing qual) mdoc ) -- cgit v1.2.3 From 4343f6c86225b6e283c73afcd8adc007fafebeff Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sun, 14 Jun 2015 10:31:18 +0100 Subject: Update tests for the CSS changes --- CHANGES | 2 + html-test/ref/Bug26.html | 12 +- html-test/ref/Bug294.html | 70 +- html-test/ref/Bug7.html | 34 +- html-test/ref/Hash.html | 44 +- html-test/ref/HiddenInstances.html | 50 +- html-test/ref/HiddenInstancesB.html | 26 +- html-test/ref/QuasiExpr.html | 26 +- html-test/ref/SpuriousSuperclassConstraints.html | 34 +- html-test/ref/Test.html | 26 +- html-test/ref/TypeFamilies.html | 834 ++++++++++++----------- html-test/ref/TypeFamilies2.html | 114 ++-- html-test/ref/ocean.css | 23 + 13 files changed, 719 insertions(+), 576 deletions(-) diff --git a/CHANGES b/CHANGES index 368002dd..cb17fde7 100644 --- a/CHANGES +++ b/CHANGES @@ -19,6 +19,8 @@ Changes in version 2.16.1 * Fix cross-module instance locations (#383) + * Fix alignment of Source link for instances in Firefox (#384) + Changes in version 2.16.0 * Experimental collapsible header support (#335) diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index 981370fa..c670264c 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -145,10 +145,12 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug26.html");}; >
    C ()C ()

    instance for ()

    Produced by Haddock version 2.15.1

    version 2.16.1

    data DP A = ProblemCtor' Adata DP A = ProblemCtor' A 
    data TP A = ProblemCtor Adata TP A = ProblemCtor A 

    Produced by Haddock version 2.15.0

    version 2.16.1

    data DP A = ProblemCtor' Adata DP A = ProblemCtor' A 
    Bar Foo FooBar Foo Foo

    Bar Foo FooBar Foo Foo

    Produced by Haddock version 2.15.0

    version 2.16.1

    Produced by Haddock version 2.15.0

    version 2.16.1

    Hash FloatHash Float 
    Hash IntHash Int 
    (Hash a, Hash b) => Hash (a, b)(Hash a, Hash b) => Hash (a, b) 
    VisibleClass IntVisibleClass Int

    VisibleClass VisibleDataVisibleClass VisibleData

    Num VisibleDataNum VisibleData

    VisibleClass VisibleDataVisibleClass VisibleData

    Produced by Haddock version 2.15.0

    version 2.16.1

    Foo BarFoo Bar

    Foo BarFoo Bar

    Produced by Haddock version 2.15.0

    version 2.16.1

    Show ExprShow Expr 

    Produced by Haddock version 2.15.0

    version 2.16.1

    Show BinOpShow BinOp 

    Produced by Haddock version 2.15.0

    version 2.16.1

    Functor (SomeType f)Functor (SomeType f) 
    Applicative f => Applicative (SomeType f)Applicative f => Applicative (SomeType f) 

    Produced by Haddock version 2.16.0

    version 2.16.1

    D FloatD Float 
    D IntD Int 
    Assoc * XAssoc * X

    Test * XTest * X

    (><) X XX XXX(><) X XX XXX 
    type Foo X = Ytype Foo X = Y

    data AssocD * X = AssocXdata AssocD * X = AssocX 
    type AssocT * X = Foo * Xtype AssocT * X = Foo * X 
    data Bat * X data Bat * X }

    type Foo * X = Ytype Foo * X = Y

    type (<>) * X a = Xtype (<>) * X a = X 
    type (<>) X XXX XX = Xtype (<>) X XXX XX = X 
    Assoc * YAssoc * Y

    Test * YTest * Y

    data Bar Ydata Bar Y 
    data AssocD * Y = AssocYdata AssocD * Y = AssocY 
    type AssocT * Y = Bat * Ytype AssocT * Y = Bat * Y 
    data Bat * Y = BatY Ydata Bat * Y = BatY Y

    type Foo * Y = Xtype Foo * Y = X

    type (<>) * Y a = atype (<>) * Y a = a 
    data Bat Z wheredata Bat Z where } -> Bat Z ZB

    Test * YTest * Y

    Test * XTest * X

    type Foo * Y = Xtype Foo * Y = X

    type Foo * X = Ytype Foo * X = Y

    data Bat Z wheredata Bat Z where } -> Bat Z ZB

    data Bat * Y = BatY Ydata Bat * Y = BatY Y

    data Bat * X data Bat * X }

    Assoc * YAssoc * Y

    Assoc * XAssoc * X

    type (<>) * Y a = atype (<>) * Y a = a 
    type (<>) * X a = Xtype (<>) * X a = X 
    type (<>) X XXX XX = Xtype (<>) X XXX XX = X 

    Produced by Haddock version 2.15.0

    version 2.16.1

    (><) X XX XXX(><) X XX XXX 
    data Bar W = BarX Zdata Bar W = BarX Z

    Shown because BarX is still exported despite Z being hidden

    type Foo Wtype Foo W

    type Foo Wtype Foo W

    type Foo X = Ytype Foo X = Y

    Produced by Haddock version 2.15.0

    version 2.16.1

    Date: Thu, 4 Jun 2015 19:27:34 +0200 Subject: Create scaffolding for Haskell source parser module. --- haddock-api/haddock-api.cabal | 1 + .../src/Haddock/Backends/Hyperlinker/Parser.hs | 36 ++++++++++++++++++++++ 2 files changed, 37 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 3bc22263..b90e3bff 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -79,6 +79,7 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker.Parser Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs new file mode 100644 index 00000000..11a92b57 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -0,0 +1,36 @@ +module Haddock.Backends.Hyperlinker.Parser (parse) where + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = Identifier + | Comment + | Whitespace + | Operator + | Symbol + +parse :: String -> [Token] +parse = tokenize . tag . chunk + +chunk :: String -> [String] +chunk = undefined + +tag :: [String] -> [(Span, String)] +tag = undefined + +tokenize :: [(Span, String)] -> [Token] +tokenize = undefined -- cgit v1.2.3 From e17f62506ecf20d61781c610d6fbb5f3c8cd132e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 19:59:27 +0200 Subject: Implement function for tagging parsed chunks with source spans. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 11a92b57..4bcc0c8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -30,7 +30,14 @@ chunk :: String -> [String] chunk = undefined tag :: [String] -> [(Span, String)] -tag = undefined +tag = + reverse . snd . foldl aux (Position 1 1, []) + where + aux (pos, cs) c = + let pos' = if c == "\n" + then pos { posRow = posRow pos + 1, posCol = 1 } + else pos { posCol = posCol pos + length c } + in (pos', (Span pos pos', c):cs) tokenize :: [(Span, String)] -> [Token] tokenize = undefined -- cgit v1.2.3 From 413f7f322cd174e2ba4116dbf53c1b3c0d6a4f77 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 21:10:26 +0200 Subject: Implement simple string chunking based on HsColour library. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 28 +++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4bcc0c8a..4e0d7382 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,5 +1,8 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where +import Data.Char +import Data.List + data Token = Token { tkType :: TokenType , tkValue :: String @@ -27,7 +30,30 @@ parse :: String -> [Token] parse = tokenize . tag . chunk chunk :: String -> [String] -chunk = undefined +chunk [] = [] +chunk str@(c:_) + | isSpace c = chunk' $ span isSpace str +chunk str + | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str + | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str + | otherwise = chunk' $ head $ lex str + +chunk' :: (String, String) -> [String] +chunk' (c, rest) = c:(chunk rest) + +chunkComment :: Int -> String -> (String, String) +chunkComment _ [] = ("", "") +chunkComment depth ('{':'-':str) = + let (c, rest) = chunkComment (depth + 1) str + in ("{-" ++ c, rest) +chunkComment depth ('-':'}':str) + | depth == 1 = ("-}", str) + | otherwise = + let (c, rest) = chunkComment (depth - 1) str + in ("-}" ++ c, rest) +chunkComment depth (e:str) = + let (c, rest) = chunkComment depth str + in (e:c, rest) tag :: [String] -> [(Span, String)] tag = -- cgit v1.2.3 From 6fb8d5abbcc92f5155fdc9596ca1c87fe87f6187 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 23:21:17 +0200 Subject: Create basic token classification method. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 104 +++++++++++++++++++-- 1 file changed, 98 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4e0d7382..be6b7ce5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -20,11 +20,18 @@ data Span = Span } data TokenType - = Identifier - | Comment - | Whitespace - | Operator - | Symbol + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkUnknown parse :: String -> [Token] parse = tokenize . tag . chunk @@ -66,4 +73,89 @@ tag = in (pos', (Span pos pos', c):cs) tokenize :: [(Span, String)] -> [Token] -tokenize = undefined +tokenize = + map aux + where + aux (sp, str) = Token + { tkType = classify str + , tkValue = str + , tkSpan = sp + } + +classify :: String -> TokenType +classify (c:_) + | isSpace c = TkSpace + | isDigit c = TkNumber + | c `elem` special = TkSpecial + | c == '#' = TkCpp + | c == '"' = TkString + | c == '\'' = TkChar +classify str + | str `elem` keywords = TkKeyword + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator + | "--" `isPrefixOf` str = TkComment + | "{-" `isPrefixOf` str = TkComment + | isIdentifier str = TkIdentifier + | otherwise = TkUnknown + +keywords :: [String] +keywords = + [ "as" + , "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "else" + , "hiding" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "forall" + , "mdo" + ] + +glyphs :: [String] +glyphs = + [ ".." + , ":" + , "::" + , "=" + , "\\" + , "|" + , "<-" + , "->" + , "@" + , "~" + , "~#" + , "=>" + , "-" + , "!" + ] + +special :: [Char] +special = "()[]{},;`" + +-- TODO: Add support for any Unicode symbol or punctuation. +-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators +symbols :: [Char] +symbols = "!#$%&*+./<=>?@\\^|-~:" + +isIdentifier :: String -> Bool +isIdentifier (c:str) + | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str +isIdentifier _ = False -- cgit v1.2.3 From 57d4c9cff1d60f7dd0f8dafae5537218b63da90f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 00:07:52 +0200 Subject: Adapt source span tagging to work with current whitespace handling. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index be6b7ce5..53ff1f65 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -67,10 +67,13 @@ tag = reverse . snd . foldl aux (Position 1 1, []) where aux (pos, cs) c = - let pos' = if c == "\n" - then pos { posRow = posRow pos + 1, posCol = 1 } - else pos { posCol = posCol pos + length c } - in (pos', (Span pos pos', c):cs) + let pos' = move pos c + in (pos', ((Span pos pos', c):cs)) + move pos str@(c:_) + | isSpace c = foldl move' pos str + move pos str = pos { posCol = posCol pos + length str } + move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } + move' pos _ = pos { posCol = posCol pos + 1 } tokenize :: [(Span, String)] -> [Token] tokenize = -- cgit v1.2.3 From c7ecc590090d7f1a4ce8e6d0233c41350202a4bd Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 00:16:15 +0200 Subject: Add record accessors to exports of hyperlinker parser module. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 53ff1f65..4130ab6c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,4 +1,9 @@ -module Haddock.Backends.Hyperlinker.Parser (parse) where +module Haddock.Backends.Hyperlinker.Parser + ( parse + , tkType, tkValue, tkSpan + , posRow, posCol + , spStart, spEnd + ) where import Data.Char import Data.List -- cgit v1.2.3 From 7b607883d0cea7a795275a2484a33bd89a3b4fc6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 11:56:01 +0200 Subject: Make parser module export all types and associated accessors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4130ab6c..7a162f6d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,8 +1,7 @@ module Haddock.Backends.Hyperlinker.Parser ( parse - , tkType, tkValue, tkSpan - , posRow, posCol - , spStart, spEnd + , Token(..), TokenType(..) + , Position(..), Span(..) ) where import Data.Char -- cgit v1.2.3 From 5e904cb1c3d769d5b99d459838b4b5368c8c1fb7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 12:59:10 +0200 Subject: Create simple HTML renderer for parsed source file. --- haddock-api/haddock-api.cabal | 3 ++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 26 ++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b90e3bff..6c6dc810 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -57,6 +57,8 @@ library exposed-modules: Documentation.Haddock + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer other-modules: Haddock @@ -79,7 +81,6 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle - Haddock.Backends.Hyperlinker.Parser Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs new file mode 100644 index 00000000..eaf5b37b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -0,0 +1,26 @@ +module Haddock.Backends.Hyperlinker.Renderer where + +import Haddock.Backends.Hyperlinker.Parser + +import Data.Monoid +import Text.XHtml + +render :: [Token] -> Html +render = body . pre . foldr (<>) noHtml . map renderToken + +renderToken :: Token -> Html +renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t + +tokenAttrs :: TokenType -> [HtmlAttr] +tokenAttrs TkIdentifier = [theclass "hs-identifier"] +tokenAttrs TkKeyword = [theclass "hs-keyword"] +tokenAttrs TkString = [theclass "hs-string"] +tokenAttrs TkChar = [theclass "hs-char"] +tokenAttrs TkNumber = [theclass "hs-number"] +tokenAttrs TkOperator = [theclass "hs-operator"] +tokenAttrs TkGlyph = [theclass "hs-glyph"] +tokenAttrs TkSpecial = [theclass "hs-special"] +tokenAttrs TkSpace = [] +tokenAttrs TkComment = [theclass "hs-comment"] +tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkUnknown = [] -- cgit v1.2.3 From 1a43f35e2dacc9837f9762fd211d63ae6cc7b4a3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 13:58:47 +0200 Subject: Add support for specifying the CSS file path in HTML source renderer. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 45 ++++++++++++++-------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index eaf5b37b..9ebb8707 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,24 +3,39 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser import Data.Monoid -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Html -render :: [Token] -> Html -render = body . pre . foldr (<>) noHtml . map renderToken +render :: Maybe FilePath -> [Token] -> Html +render css tokens = header css <> body tokens -renderToken :: Token -> Html -renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t +body :: [Token] -> Html +body = Html.body . Html.pre . mconcat . map token + +header :: Maybe FilePath -> Html +header Nothing = Html.noHtml +header (Just css) = + Html.header $ Html.thelink Html.noHtml ! attrs + where + attrs = + [ Html.rel "stylesheet" + , Html.href css + , Html.thetype "text/css" + ] + +token :: Token -> Html +token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t tokenAttrs :: TokenType -> [HtmlAttr] -tokenAttrs TkIdentifier = [theclass "hs-identifier"] -tokenAttrs TkKeyword = [theclass "hs-keyword"] -tokenAttrs TkString = [theclass "hs-string"] -tokenAttrs TkChar = [theclass "hs-char"] -tokenAttrs TkNumber = [theclass "hs-number"] -tokenAttrs TkOperator = [theclass "hs-operator"] -tokenAttrs TkGlyph = [theclass "hs-glyph"] -tokenAttrs TkSpecial = [theclass "hs-special"] +tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"] +tokenAttrs TkKeyword = [Html.theclass "hs-keyword"] +tokenAttrs TkString = [Html.theclass "hs-string"] +tokenAttrs TkChar = [Html.theclass "hs-char"] +tokenAttrs TkNumber = [Html.theclass "hs-number"] +tokenAttrs TkOperator = [Html.theclass "hs-operator"] +tokenAttrs TkGlyph = [Html.theclass "hs-glyph"] +tokenAttrs TkSpecial = [Html.theclass "hs-special"] tokenAttrs TkSpace = [] -tokenAttrs TkComment = [theclass "hs-comment"] -tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkComment = [Html.theclass "hs-comment"] +tokenAttrs TkCpp = [Html.theclass "hs-cpp"] tokenAttrs TkUnknown = [] -- cgit v1.2.3 From 01a2e7c5ab873c0041624a6ec0b0a54eb7da60cc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 14:39:28 +0200 Subject: Fix identifier recognition in Haskell source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 7a162f6d..9d58728f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -163,6 +163,9 @@ symbols :: [Char] symbols = "!#$%&*+./<=>?@\\^|-~:" isIdentifier :: String -> Bool -isIdentifier (c:str) - | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str +isIdentifier (s:str) + | (isLower' s || isUpper s) && all isAlphaNum' str = True + where + isLower' c = isLower c || c == '_' + isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' isIdentifier _ = False -- cgit v1.2.3 From ffd0e8028f15f3616f1b3eaaf98459c0c75c6313 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 14:56:59 +0200 Subject: Fix comment recognition in Haskell source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 9d58728f..29edb4c3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -90,6 +90,9 @@ tokenize = } classify :: String -> TokenType +classify str + | "--" `isPrefixOf` str = TkComment + | "{-" `isPrefixOf` str = TkComment classify (c:_) | isSpace c = TkSpace | isDigit c = TkNumber @@ -101,8 +104,6 @@ classify str | str `elem` keywords = TkKeyword | str `elem` glyphs = TkGlyph | all (`elem` symbols) str = TkOperator - | "--" `isPrefixOf` str = TkComment - | "{-" `isPrefixOf` str = TkComment | isIdentifier str = TkIdentifier | otherwise = TkUnknown -- cgit v1.2.3 From e5bd5d39550692f936c973637f8ec8d314919359 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 15:12:40 +0200 Subject: Add support for recognizing compiler pragmas in source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 29edb4c3..0e1ad5b2 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -35,6 +35,7 @@ data TokenType | TkSpace | TkComment | TkCpp + | TkPragma | TkUnknown parse :: String -> [Token] @@ -92,6 +93,7 @@ tokenize = classify :: String -> TokenType classify str | "--" `isPrefixOf` str = TkComment + | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment classify (c:_) | isSpace c = TkSpace diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 9ebb8707..39d7d183 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,4 +38,5 @@ tokenAttrs TkSpecial = [Html.theclass "hs-special"] tokenAttrs TkSpace = [] tokenAttrs TkComment = [Html.theclass "hs-comment"] tokenAttrs TkCpp = [Html.theclass "hs-cpp"] +tokenAttrs TkPragma = [Html.theclass "hs-pragma"] tokenAttrs TkUnknown = [] -- cgit v1.2.3 From d275f87c4cfa1e8da042f70659331121afa9a15c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 19:27:37 +0200 Subject: Create scaffolding of module for associating tokens with AST names. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6c6dc810..109e5f95 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -59,6 +59,7 @@ library Documentation.Haddock Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Ast other-modules: Haddock diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs new file mode 100644 index 00000000..abd3ca2b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -0,0 +1,20 @@ +module Haddock.Backends.Hyperlinker.Ast where + +import qualified GHC + +import Haddock.Backends.Hyperlinker.Parser + +data RichToken = RichToken + { rtkToken :: Token + , rtkName :: Maybe GHC.Name + } + +enrich :: GHC.RenamedSource -> [Token] -> [RichToken] +enrich src = + map $ \token -> RichToken + { rtkToken = token + , rtkName = lookupName src $ tkSpan token + } + +lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name +lookupName = undefined -- cgit v1.2.3 From 74de0021815f0642a89017fbb1fbdf18064cb5ea Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 19:36:53 +0200 Subject: Implement utility method for extracting variable identifiers from AST. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index abd3ca2b..62c0d439 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE RankNTypes #-} + module Haddock.Backends.Hyperlinker.Ast where import qualified GHC +import Data.Data +import Control.Applicative import Haddock.Backends.Hyperlinker.Parser @@ -18,3 +22,15 @@ enrich src = lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name lookupName = undefined + +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)] +variables = + everything (<|>) var + where + var term = case cast term of + (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) + _ -> empty -- cgit v1.2.3 From d06a2b502e7909dff517a7c825e772b493bade24 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 20:04:02 +0200 Subject: Create simple mechanism for associating tokens with AST names. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 30 +++++++++++++++++----- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 62c0d439..031ddd5c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,11 +2,13 @@ module Haddock.Backends.Hyperlinker.Ast where +import Haddock.Backends.Hyperlinker.Parser + import qualified GHC -import Data.Data -import Control.Applicative -import Haddock.Backends.Hyperlinker.Parser +import Control.Applicative +import Data.Data +import Data.Maybe data RichToken = RichToken { rtkToken :: Token @@ -17,20 +19,34 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkName = lookupName src $ tkSpan token + , rtkName = lookupBySpan (tkSpan token) nameMap } + where + nameMap = variables src + +type NameMap = [(GHC.SrcSpan, GHC.Name)] -lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name -lookupName = undefined +lookupBySpan :: Span -> NameMap -> Maybe GHC.Name +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) -variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)] +variables :: GHC.RenamedSource -> NameMap variables = everything (<|>) var where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) _ -> empty + +matches :: Span -> GHC.SrcSpan -> Bool +matches tspan (GHC.RealSrcSpan aspan) + | rs && cs && re && ce = True + where + rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan + cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan + re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan + ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan +matches _ _ = False -- cgit v1.2.3 From cb3ece1a493eb444ccb61b6ad3c74e922184b63e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 21:43:15 +0200 Subject: Add dummy support for hyperlinking named tokens. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 39d7d183..32d2c863 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,16 +1,20 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser +import Haddock.Backends.Hyperlinker.Ast + +import qualified GHC +import qualified Name as GHC import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html -render :: Maybe FilePath -> [Token] -> Html +render :: Maybe FilePath -> [RichToken] -> Html render css tokens = header css <> body tokens -body :: [Token] -> Html -body = Html.body . Html.pre . mconcat . map token +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Html header Nothing = Html.noHtml @@ -23,6 +27,10 @@ header (Just css) = , Html.thetype "text/css" ] +richToken :: RichToken -> Html +richToken (RichToken t Nothing) = token t +richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name + token :: Token -> Html token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t @@ -40,3 +48,12 @@ tokenAttrs TkComment = [Html.theclass "hs-comment"] tokenAttrs TkCpp = [Html.theclass "hs-cpp"] tokenAttrs TkPragma = [Html.theclass "hs-pragma"] tokenAttrs TkUnknown = [] + +nameAttrs :: GHC.Name -> [HtmlAttr] +nameAttrs name = + [ Html.href (maybe "" id mmod ++ "#" ++ ident) + , Html.theclass "varid-reference" + ] + where + mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name + ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From 7d43b8a8c9538692beb91a4c3a485e82b40559ab Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 22:37:28 +0200 Subject: Fix span matcher bug causing wrong items being hyperlinked. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 031ddd5c..7d88b7fb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -48,5 +48,5 @@ matches tspan (GHC.RealSrcSpan aspan) rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan - ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan + ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan matches _ _ = False -- cgit v1.2.3 From 9a51a6d3f686736354e26137363ea979a5e38076 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 23:40:36 +0200 Subject: Constrain elements exported by hyperlinker modules. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 ++++- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 7d88b7fb..a24945ea 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RankNTypes #-} -module Haddock.Backends.Hyperlinker.Ast where +module Haddock.Backends.Hyperlinker.Ast + ( enrich + , RichToken(..) + ) where import Haddock.Backends.Hyperlinker.Parser diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 32d2c863..3c6fe14f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,4 +1,4 @@ -module Haddock.Backends.Hyperlinker.Renderer where +module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast -- cgit v1.2.3 From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 7 Jun 2015 21:35:55 +0200 Subject: Add support for type token recognition. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 35 +++++++++--- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 64 ++++++++++++++-------- 2 files changed, 68 insertions(+), 31 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index a24945ea..0ccf010b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,7 +2,7 @@ module Haddock.Backends.Hyperlinker.Ast ( enrich - , RichToken(..) + , RichToken(..), RichTokenType(..), TokenDetails(..) ) where import Haddock.Backends.Hyperlinker.Parser @@ -15,33 +15,52 @@ import Data.Maybe data RichToken = RichToken { rtkToken :: Token - , rtkName :: Maybe GHC.Name + , rtkDetails :: Maybe TokenDetails } +data TokenDetails = TokenDetails + { rtkType :: RichTokenType + , rtkName :: GHC.Name + } + +data RichTokenType + = RtkVar + | RtkType + enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkName = lookupBySpan (tkSpan token) nameMap + , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - nameMap = variables src + detailsMap = variables src ++ types src -type NameMap = [(GHC.SrcSpan, GHC.Name)] +type DetailsMap = [(GHC.SrcSpan, TokenDetails)] -lookupBySpan :: Span -> NameMap -> Maybe GHC.Name +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) -variables :: GHC.RenamedSource -> NameMap +variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var where var term = case cast term of - (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) + (Just (GHC.L sspan (GHC.HsVar name))) -> + pure (sspan, TokenDetails RtkVar name) + _ -> empty + +types :: GHC.RenamedSource -> DetailsMap +types = + everything (<|>) ty + where + ty term = case cast term of + (Just (GHC.L sspan (GHC.HsTyVar name))) -> + pure (sspan, TokenDetails RtkType name) _ -> empty matches :: Span -> GHC.SrcSpan -> Bool diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 3c6fe14f..c2bca438 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -6,10 +6,14 @@ import Haddock.Backends.Hyperlinker.Ast import qualified GHC import qualified Name as GHC +import Data.List import Data.Monoid + import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html +type StyleClass = String + render :: Maybe FilePath -> [RichToken] -> Html render css tokens = header css <> body tokens @@ -28,29 +32,43 @@ header (Just css) = ] richToken :: RichToken -> Html -richToken (RichToken t Nothing) = token t -richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name - -token :: Token -> Html -token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t - -tokenAttrs :: TokenType -> [HtmlAttr] -tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"] -tokenAttrs TkKeyword = [Html.theclass "hs-keyword"] -tokenAttrs TkString = [Html.theclass "hs-string"] -tokenAttrs TkChar = [Html.theclass "hs-char"] -tokenAttrs TkNumber = [Html.theclass "hs-number"] -tokenAttrs TkOperator = [Html.theclass "hs-operator"] -tokenAttrs TkGlyph = [Html.theclass "hs-glyph"] -tokenAttrs TkSpecial = [Html.theclass "hs-special"] -tokenAttrs TkSpace = [] -tokenAttrs TkComment = [Html.theclass "hs-comment"] -tokenAttrs TkCpp = [Html.theclass "hs-cpp"] -tokenAttrs TkPragma = [Html.theclass "hs-pragma"] -tokenAttrs TkUnknown = [] - -nameAttrs :: GHC.Name -> [HtmlAttr] -nameAttrs name = +richToken (RichToken tok Nothing) = + tokenSpan tok ! attrs + where + attrs = [ multiclass . tokenStyle . tkType $ tok ] +richToken (RichToken tok (Just det)) = + Html.anchor content ! (anchorAttrs . rtkName) det + where + content = tokenSpan tok ! [ multiclass style] + style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det + +tokenSpan :: Token -> Html +tokenSpan = Html.thespan . Html.toHtml . tkValue + +richTokenStyle :: RichTokenType -> [StyleClass] +richTokenStyle RtkVar = ["hs-var"] +richTokenStyle RtkType = ["hs-type"] + +tokenStyle :: TokenType -> [StyleClass] +tokenStyle TkIdentifier = ["hs-identifier"] +tokenStyle TkKeyword = ["hs-keyword"] +tokenStyle TkString = ["hs-string"] +tokenStyle TkChar = ["hs-char"] +tokenStyle TkNumber = ["hs-number"] +tokenStyle TkOperator = ["hs-operator"] +tokenStyle TkGlyph = ["hs-glyph"] +tokenStyle TkSpecial = ["hs-special"] +tokenStyle TkSpace = [] +tokenStyle TkComment = ["hs-comment"] +tokenStyle TkCpp = ["hs-cpp"] +tokenStyle TkPragma = ["hs-pragma"] +tokenStyle TkUnknown = [] + +multiclass :: [StyleClass] -> HtmlAttr +multiclass = Html.theclass . intercalate " " + +anchorAttrs :: GHC.Name -> [HtmlAttr] +anchorAttrs name = [ Html.href (maybe "" id mmod ++ "#" ++ ident) , Html.theclass "varid-reference" ] -- cgit v1.2.3 From 70656933ca6935bde0a00310f37440e02c3f21ff Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:13:12 +0200 Subject: Add support for binding token recognition. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 0ccf010b..19ebbe77 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Backends.Hyperlinker.Ast ( enrich @@ -26,6 +27,7 @@ data TokenDetails = TokenDetails data RichTokenType = RtkVar | RtkType + | RtkBind enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -34,7 +36,7 @@ enrich src = , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - detailsMap = variables src ++ types src + detailsMap = variables src ++ types src ++ binds src type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -45,6 +47,9 @@ everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) +combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x + variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var @@ -63,6 +68,19 @@ types = pure (sspan, TokenDetails RtkType name) _ -> empty +binds :: GHC.RenamedSource -> DetailsMap +binds = + everything (<|>) (fun `combine` pat) + where + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + pat term = case cast term of + (Just (GHC.L sspan (GHC.VarPat name))) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | rs && cs && re && ce = True diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index c2bca438..57851c22 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -48,6 +48,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] +richTokenStyle RtkBind = ["hs-bind"] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] -- cgit v1.2.3 From 21984e4cfcc076ce8cbee934028a1b37aaca930b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:54:58 +0200 Subject: Implement go-to-definition mechanism for local bindings. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 30 +++++++++++++++++----- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 57851c22..995e24e6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -5,6 +5,7 @@ import Haddock.Backends.Hyperlinker.Ast import qualified GHC import qualified Name as GHC +import qualified Unique as GHC import Data.List import Data.Monoid @@ -37,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - Html.anchor content ! (anchorAttrs . rtkName) det + internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -48,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = ["hs-bind"] +richTokenStyle RtkBind = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -68,11 +69,26 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " -anchorAttrs :: GHC.Name -> [HtmlAttr] -anchorAttrs name = - [ Html.href (maybe "" id mmod ++ "#" ++ ident) - , Html.theclass "varid-reference" - ] +internalAnchor :: TokenDetails -> Html -> Html +internalAnchor (TokenDetails RtkBind name) content = + Html.anchor content ! [ Html.name $ internalAnchorIdent name ] +internalAnchor _ content = content + +internalAnchorIdent :: GHC.Name -> String +internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique + +hyperlink :: TokenDetails -> Html -> Html +hyperlink (TokenDetails _ name) = if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink name + +internalHyperlink :: GHC.Name -> Html -> Html +internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + +externalHyperlink :: GHC.Name -> Html -> Html +externalHyperlink name content = + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From c84a3ef8ebca5fb396ee9dc8cb2654f7891f5c0e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 14:12:58 +0200 Subject: Implement module export- and import-list item hyperlinking. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 19ebbe77..2325aa21 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -36,7 +36,12 @@ enrich src = , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - detailsMap = variables src ++ types src ++ binds src + detailsMap = concat + [ variables src + , types src + , binds src + , imports src + ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -81,6 +86,19 @@ binds = pure (sspan, TokenDetails RtkBind name) _ -> empty +imports :: GHC.RenamedSource -> DetailsMap +imports = + everything (<|>) ie + where + ie term = case cast term of + (Just (GHC.IEVar v)) -> pure $ var v + (Just (GHC.IEThingAbs t)) -> pure $ typ t + (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs + _ -> empty + typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name) + var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name) + matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | rs && cs && re && ce = True -- cgit v1.2.3 From fab61bb80c2d8059e91aece7677cf349cd34a8db Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 15:05:35 +0200 Subject: Fix span matching to allow parenthesized operators hyperlinking. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 2325aa21..05d6a52e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -101,10 +101,10 @@ imports = matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) - | rs && cs && re && ce = True + | saspan <= stspan && etspan <= easpan = True where - rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan - cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan - re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan - ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan + stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) + etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) + saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) + easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) matches _ _ = False -- cgit v1.2.3 From b31513dbacb48102b4c5d2fd6de1982161d81fae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 15:16:06 +0200 Subject: Fix weird hyperlinking of parenthesized operators. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++++- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 05d6a52e..2749096e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -33,7 +33,7 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkDetails = lookupBySpan (tkSpan token) detailsMap + , rtkDetails = enrichToken token detailsMap } where detailsMap = concat @@ -45,6 +45,11 @@ enrich src = type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +enrichToken :: Token -> DetailsMap -> Maybe TokenDetails +enrichToken (Token typ _ spn) dm + | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm +enrichToken _ _ = Nothing + lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0e1ad5b2..70a69279 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -37,6 +37,7 @@ data TokenType | TkCpp | TkPragma | TkUnknown + deriving (Eq) parse :: String -> [Token] parse = tokenize . tag . chunk -- cgit v1.2.3 From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 01:03:13 +0200 Subject: Add support for type declaration anchors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 ++++++++++++++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 14 +++++++++++--- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 2749096e..39bbacf5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -28,6 +28,7 @@ data RichTokenType = RtkVar | RtkType | RtkBind + | RtkDecl enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -36,11 +37,12 @@ enrich src = , rtkDetails = enrichToken token detailsMap } where - detailsMap = concat - [ variables src - , types src - , binds src - , imports src + detailsMap = concatMap ($ src) + [ variables + , types + , binds + , imports + , decls ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -91,6 +93,15 @@ binds = pure (sspan, TokenDetails RtkBind name) _ -> empty +decls :: GHC.RenamedSource -> DetailsMap +decls (group, _, _, _) = concatMap ($ group) + [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + ] + where + typ (GHC.L _ t) = + let (GHC.L sspan name) = GHC.tcdLName t + in (sspan, TokenDetails RtkDecl name) + imports :: GHC.RenamedSource -> DetailsMap imports = everything (<|>) ie diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 995e24e6..b7cc5aeb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - internalAnchor det . hyperlink det $ content + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = [] +richTokenStyle _ = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -69,11 +69,19 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " +externalAnchor :: TokenDetails -> Html -> Html +externalAnchor (TokenDetails RtkDecl name) content = + Html.anchor content ! [ Html.name $ externalAnchorIdent name ] +externalAnchor _ content = content + internalAnchor :: TokenDetails -> Html -> Html internalAnchor (TokenDetails RtkBind name) content = Html.anchor content ! [ Html.name $ internalAnchorIdent name ] internalAnchor _ content = content +externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent = GHC.occNameString . GHC.nameOccName + internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique @@ -91,4 +99,4 @@ externalHyperlink name content = Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = GHC.occNameString . GHC.nameOccName $ name + ident = externalAnchorIdent name -- cgit v1.2.3 From c6786894f71809ecfa377a44beab0771a3bc7985 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 01:36:49 +0200 Subject: Add support for top-level function declaration anchors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 39bbacf5..cb9508ef 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -40,9 +40,9 @@ enrich src = detailsMap = concatMap ($ src) [ variables , types + , decls , binds , imports - , decls ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -96,11 +96,16 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + , everything (<|>) fun ] where typ (GHC.L _ t) = let (GHC.L sspan name) = GHC.tcdLName t in (sspan, TokenDetails RtkDecl name) + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) + | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name) + _ -> empty imports :: GHC.RenamedSource -> DetailsMap imports = -- cgit v1.2.3 From 1064953c6590c05303c6cbd2230b9e13d3ba1376 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 10:57:30 +0200 Subject: Fix external anchors to contain HTML file extension. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b7cc5aeb..99a0f337 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -96,7 +96,7 @@ internalHyperlink name content = externalHyperlink :: GHC.Name -> Html -> Html externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = externalAnchorIdent name -- cgit v1.2.3 From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 21:49:46 +0200 Subject: Refactor the way AST names are handled within detailed tokens. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 37 +++++++++++----------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 17 ++++++---- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index cb9508ef..3c07ff3c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,7 +3,7 @@ module Haddock.Backends.Hyperlinker.Ast ( enrich - , RichToken(..), RichTokenType(..), TokenDetails(..) + , RichToken(..), TokenDetails(..), rtkName ) where import Haddock.Backends.Hyperlinker.Parser @@ -19,16 +19,17 @@ data RichToken = RichToken , rtkDetails :: Maybe TokenDetails } -data TokenDetails = TokenDetails - { rtkType :: RichTokenType - , rtkName :: GHC.Name - } +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name -data RichTokenType - = RtkVar - | RtkType - | RtkBind - | RtkDecl +rtkName :: TokenDetails -> GHC.Name +rtkName (RtkVar name) = name +rtkName (RtkType name) = name +rtkName (RtkBind name) = name +rtkName (RtkDecl name) = name enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -68,7 +69,7 @@ variables = where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> - pure (sspan, TokenDetails RtkVar name) + pure (sspan, RtkVar name) _ -> empty types :: GHC.RenamedSource -> DetailsMap @@ -77,7 +78,7 @@ types = where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar name))) -> - pure (sspan, TokenDetails RtkType name) + pure (sspan, RtkType name) _ -> empty binds :: GHC.RenamedSource -> DetailsMap @@ -86,11 +87,11 @@ binds = where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> - pure (sspan, TokenDetails RtkBind name) + pure (sspan, RtkBind name) _ -> empty pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> - pure (sspan, TokenDetails RtkBind name) + pure (sspan, RtkBind name) _ -> empty decls :: GHC.RenamedSource -> DetailsMap @@ -101,10 +102,10 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = let (GHC.L sspan name) = GHC.tcdLName t - in (sspan, TokenDetails RtkDecl name) + in (sspan, RtkDecl name) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) - | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty imports :: GHC.RenamedSource -> DetailsMap @@ -117,8 +118,8 @@ imports = (Just (GHC.IEThingAll t)) -> pure $ typ t (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs _ -> empty - typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name) - var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name) + typ (GHC.L sspan name) = (sspan, RtkType name) + var (GHC.L sspan name) = (sspan, RtkVar name) matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 99a0f337..e08d8974 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -41,14 +41,14 @@ richToken (RichToken tok (Just det)) = externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] - style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det + style = (tokenStyle . tkType) tok ++ richTokenStyle det tokenSpan :: Token -> Html tokenSpan = Html.thespan . Html.toHtml . tkValue -richTokenStyle :: RichTokenType -> [StyleClass] -richTokenStyle RtkVar = ["hs-var"] -richTokenStyle RtkType = ["hs-type"] +richTokenStyle :: TokenDetails -> [StyleClass] +richTokenStyle (RtkVar _) = ["hs-var"] +richTokenStyle (RtkType _) = ["hs-type"] richTokenStyle _ = [] tokenStyle :: TokenType -> [StyleClass] @@ -70,12 +70,12 @@ multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " externalAnchor :: TokenDetails -> Html -> Html -externalAnchor (TokenDetails RtkDecl name) content = +externalAnchor (RtkDecl name) content = Html.anchor content ! [ Html.name $ externalAnchorIdent name ] externalAnchor _ content = content internalAnchor :: TokenDetails -> Html -> Html -internalAnchor (TokenDetails RtkBind name) content = +internalAnchor (RtkBind name) content = Html.anchor content ! [ Html.name $ internalAnchorIdent name ] internalAnchor _ content = content @@ -86,9 +86,12 @@ internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique hyperlink :: TokenDetails -> Html -> Html -hyperlink (TokenDetails _ name) = if GHC.isInternalName name +hyperlink details = + if GHC.isInternalName $ name then internalHyperlink name else externalHyperlink name + where + name = rtkName details internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = -- cgit v1.2.3 From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 22:22:49 +0200 Subject: Implement hyperlinking of imported module names. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 19 +++++++++------ .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 28 +++++++++++++--------- 2 files changed, 29 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3c07ff3c..10389958 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -24,12 +24,14 @@ data TokenDetails | RtkType GHC.Name | RtkBind GHC.Name | RtkDecl GHC.Name + | RtkModule GHC.ModuleName -rtkName :: TokenDetails -> GHC.Name -rtkName (RtkVar name) = name -rtkName (RtkType name) = name -rtkName (RtkBind name) = name -rtkName (RtkDecl name) = name +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty imports :: GHC.RenamedSource -> DetailsMap -imports = - everything (<|>) ie +imports src@(_, imps, _, _) = + everything (<|>) ie src ++ map (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var v @@ -120,6 +122,9 @@ imports = _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) + imp idecl = + let (GHC.L sspan name) = GHC.ideclName idecl + in (sspan, RtkModule name) matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index e08d8974..70524759 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -8,6 +8,7 @@ import qualified Name as GHC import qualified Unique as GHC import Data.List +import Data.Maybe import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) @@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique hyperlink :: TokenDetails -> Html -> Html -hyperlink details = - if GHC.isInternalName $ name - then internalHyperlink name - else externalHyperlink name - where - name = rtkName details +hyperlink details = case rtkName details of + Left name -> + if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink mname (Just name) + where + mname = GHC.moduleName <$> GHC.nameModule_maybe name + Right name -> externalHyperlink (Just name) Nothing internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: GHC.Name -> Html -> Html -externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] +externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html +externalHyperlink mmname miname content = + Html.anchor content ! [ Html.href $ path ++ anchor ] where - mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = externalAnchorIdent name + path = fromMaybe "" $ modulePath <$> mmname + anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + +modulePath :: GHC.ModuleName -> String +modulePath name = GHC.moduleNameString name ++ ".html" -- cgit v1.2.3 From ebd60c5cd0c3642c2d5542c0e126be0a4ec111d9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 23:43:31 +0200 Subject: Fix parsing of single line comments with broken up newlines. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 70a69279..3ecfc7e7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -47,13 +47,23 @@ chunk [] = [] chunk str@(c:_) | isSpace c = chunk' $ span isSpace str chunk str - | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str + | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str | otherwise = chunk' $ head $ lex str chunk' :: (String, String) -> [String] chunk' (c, rest) = c:(chunk rest) +spanToNewline :: String -> (String, String) +spanToNewline [] = ([], []) +spanToNewline ('\\':'\n':str) = + let (str', rest) = spanToNewline str + in ('\\':'\n':str', rest) +spanToNewline ('\n':str) = ("\n", str) +spanToNewline (c:str) = + let (str', rest) = spanToNewline str + in (c:str', rest) + chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = -- cgit v1.2.3 From a7888aefa4011d919b887ff31fcf8651af5632be Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 00:25:56 +0200 Subject: Fix bug with improper newline handling. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3ecfc7e7..bfee4a7f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -59,7 +59,7 @@ spanToNewline [] = ([], []) spanToNewline ('\\':'\n':str) = let (str', rest) = spanToNewline str in ('\\':'\n':str', rest) -spanToNewline ('\n':str) = ("\n", str) +spanToNewline str@('\n':_) = ("", str) spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) -- cgit v1.2.3 From 45cc27fe79492a7b921574796a7ea8fdac4c5af2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 14:29:59 +0200 Subject: Fix issues with escaped newlines in comments. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index bfee4a7f..fa5a58b3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -82,14 +82,11 @@ tag :: [String] -> [(Span, String)] tag = reverse . snd . foldl aux (Position 1 1, []) where - aux (pos, cs) c = - let pos' = move pos c - in (pos', ((Span pos pos', c):cs)) - move pos str@(c:_) - | isSpace c = foldl move' pos str - move pos str = pos { posCol = posCol pos + length str } - move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } - move' pos _ = pos { posCol = posCol pos + 1 } + aux (pos, cs) str = + let pos' = foldl move pos str + in (pos', (Span pos pos', str):cs) + move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } + move pos _ = pos { posCol = posCol pos + 1 } tokenize :: [(Span, String)] -> [Token] tokenize = -- cgit v1.2.3 From 61942ce564edcb3c0a64051042c8ed850f2090bd Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 15:19:59 +0200 Subject: Add support for parsing C preprocessor macros. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index fa5a58b3..7f408165 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker.Parser import Data.Char import Data.List +import Data.Maybe data Token = Token { tkType :: TokenType @@ -45,14 +46,15 @@ parse = tokenize . tag . chunk chunk :: String -> [String] chunk [] = [] chunk str@(c:_) - | isSpace c = chunk' $ span isSpace str + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str + in [space] ++ maybeToList mcpp ++ chunk rest chunk str | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str | otherwise = chunk' $ head $ lex str - -chunk' :: (String, String) -> [String] -chunk' (c, rest) = c:(chunk rest) + where + chunk' (c, rest) = c:(chunk rest) spanToNewline :: String -> (String, String) spanToNewline [] = ([], []) @@ -64,6 +66,16 @@ spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) +spanSpaceOrCpp :: String -> (String, Maybe String, String) +spanSpaceOrCpp ('\n':'#':str) = + let (str', rest) = spanToNewline str + in ("\n", Just $ '#':str', rest) +spanSpaceOrCpp (c:str') + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str' + in (c:space, mcpp, rest) +spanSpaceOrCpp str = ("", Nothing, str) + chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = -- cgit v1.2.3 From 416c384a981593005c9c6bf87ac27b7c2f9b8695 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 21 Jun 2015 23:48:03 +0200 Subject: Add some documentation for parser module of source hyperlinker. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 39 ++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 7f408165..6e195dba 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -40,9 +40,20 @@ data TokenType | TkUnknown deriving (Eq) +-- | Turn source code string into a stream of more descriptive tokens. +-- +-- Result should retain original file layout (including comments, whitespace, +-- etc.), i.e. the following "law" should hold: +-- +-- @concat . map 'tkValue' . 'parse' = id@ parse :: String -> [Token] parse = tokenize . tag . chunk +-- | Split raw source string to more meaningful chunks. +-- +-- This is the initial stage of tokenization process. Each chunk is either +-- a comment (including comment delimiters), a whitespace string, preprocessor +-- macro (and all its content until the end of a line) or valid Haskell lexeme. chunk :: String -> [String] chunk [] = [] chunk str@(c:_) @@ -56,6 +67,11 @@ chunk str where chunk' (c, rest) = c:(chunk rest) +-- | Split input to "first line" string and the rest of it. +-- +-- Ideally, this should be done simply with @'break' (== '\n')@. However, +-- Haskell also allows line-unbreaking (or whatever it is called) so things +-- are not as simple and this function deals with that. spanToNewline :: String -> (String, String) spanToNewline [] = ([], []) spanToNewline ('\\':'\n':str) = @@ -66,6 +82,16 @@ spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) +-- | Split input to whitespace string, (optional) preprocessor directive and +-- the rest of it. +-- +-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input +-- to whitespace. The problem is with /#/ symbol - if it is placed at the very +-- beginning of a line, it should be recognized as preprocessor macro. In any +-- other case, it is ordinary Haskell symbol and can be used to declare +-- operators. Hence, while dealing with whitespace we also check whether there +-- happens to be /#/ symbol just after a newline character - if that is the +-- case, we begin treating the whole line as preprocessor macro. spanSpaceOrCpp :: String -> (String, Maybe String, String) spanSpaceOrCpp ('\n':'#':str) = let (str', rest) = spanToNewline str @@ -76,6 +102,10 @@ spanSpaceOrCpp (c:str') in (c:space, mcpp, rest) spanSpaceOrCpp str = ("", Nothing, str) +-- | Split input to comment content (including delimiters) and the rest. +-- +-- Again, some more logic than simple 'span' is required because of Haskell +-- comment nesting policy. chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = @@ -90,6 +120,7 @@ chunkComment depth (e:str) = let (c, rest) = chunkComment depth str in (e:c, rest) +-- | Assign source location for each chunk in given stream. tag :: [String] -> [(Span, String)] tag = reverse . snd . foldl aux (Position 1 1, []) @@ -100,6 +131,7 @@ tag = move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } move pos _ = pos { posCol = posCol pos + 1 } +-- | Turn unrecognised chunk stream to more descriptive token stream. tokenize :: [(Span, String)] -> [Token] tokenize = map aux @@ -110,6 +142,13 @@ tokenize = , tkSpan = sp } +-- | Classify given string as appropriate Haskell token. +-- +-- This method is based on Haskell 98 Report lexical structure description: +-- https://www.haskell.org/onlinereport/lexemes.html +-- +-- However, this is probably far from being perfect and most probably does not +-- handle correctly all corner cases. classify :: String -> TokenType classify str | "--" `isPrefixOf` str = TkComment -- cgit v1.2.3 From 937a6011d253a77cda98ec112a839cd08ac7e7ca Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 00:20:44 +0200 Subject: Add some documentation for AST module of source hyperlinker. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 56 ++++++++++++++++++---- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 10389958..275f10e9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -33,6 +33,7 @@ rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name +-- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken @@ -48,23 +49,24 @@ enrich src = , imports ] +-- | A map containing association between source locations and "details" of +-- this location. +-- +-- For the time being, it is just a list of pairs. However, looking up things +-- in such structure has linear complexity. We cannot use any hashmap-like +-- stuff because source locations are not ordered. In the future, this should +-- be replaced with interval tree data structure. type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) + enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm enrichToken _ _ = Nothing -lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) - -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) - -combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x - +-- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var @@ -74,6 +76,7 @@ variables = pure (sspan, RtkVar name) _ -> empty +-- | Obtain details map for types. types :: GHC.RenamedSource -> DetailsMap types = everything (<|>) ty @@ -83,6 +86,11 @@ types = pure (sspan, RtkType name) _ -> empty +-- | Obtain details map for identifier bindings. +-- +-- That includes both identifiers bound by pattern matching or declared using +-- ordinary assignment (in top-level declarations, let-expressions and where +-- clauses). binds :: GHC.RenamedSource -> DetailsMap binds = everything (<|>) (fun `combine` pat) @@ -96,6 +104,7 @@ binds = pure (sspan, RtkBind name) _ -> empty +-- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds @@ -110,6 +119,10 @@ decls (group, _, _, _) = concatMap ($ group) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty +-- | Obtain details map for import declarations. +-- +-- This map also includes type and variable details for items in export and +-- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = everything (<|>) ie src ++ map (imp . GHC.unLoc) imps @@ -126,6 +139,15 @@ imports src@(_, imps, _, _) = let (GHC.L sspan name) = GHC.ideclName idecl in (sspan, RtkModule name) +-- | Check whether token stream span matches GHC source span. +-- +-- Currently, it is implemented as checking whether "our" span is contained +-- in GHC span. The reason for that is because GHC span are generally wider +-- and may spread across couple tokens. For example, @(>>=)@ consists of three +-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable +-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ +-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span +-- associated with @quux@ contains all five elements. matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | saspan <= stspan && etspan <= easpan = True @@ -135,3 +157,17 @@ matches tspan (GHC.RealSrcSpan aspan) saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) matches _ _ = False + +-- | Perform a query on each level of a tree. +-- +-- This is stolen directly from SYB package and copied here to not introduce +-- additional dependencies. +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +-- | Combine two queries into one using alternative combinator. +combine :: Alternative f => (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x -- cgit v1.2.3 From ce4b5607f84506e5aafd1994e02300c2e3ee475d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 12:27:55 +0200 Subject: Add command line option for generating hyperlinked source. --- haddock-api/src/Haddock/Options.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index e847333e..c9d5688c 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -66,6 +66,7 @@ data Flag | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_HyperlinkedSource | Flag_Help | Flag_Verbosity String | Flag_Version @@ -116,6 +117,8 @@ options backwardsCompat = Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too", + Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) + "generate highlighted and hyperlinked source code (for use with --html)", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) -- cgit v1.2.3 From 3eb96a6bbc1f61b81c20df882e243c4d9f4a9404 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 12:51:49 +0200 Subject: Extend module interface with rich source token stream field. --- haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Types.hs | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7491a01e..63d44366 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -145,6 +145,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap + , ifaceTokenizedSrc = Nothing } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 14995098..fbb5f44c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,6 +35,7 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable import Control.Monad (ap) +import Haddock.Backends.Hyperlinker.Ast ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -125,6 +126,10 @@ data Interface = Interface -- | Warnings for things defined in this module. , ifaceWarningMap :: !WarningMap + + -- | Tokenized source code of module (avaliable if Haddock is invoked with + -- source generation flag). + , ifaceTokenizedSrc :: !(Maybe [RichToken]) } type WarningMap = Map Name (Doc Name) -- cgit v1.2.3 From 4190a05c4abc710d253212017fb4a654ebde1862 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 14:04:41 +0200 Subject: Implement source tokenization during interface creation process. --- haddock-api/src/Haddock/Interface/Create.hs | 30 ++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 63d44366..59f7076f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,8 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Ast as Hyperlinker +import Haddock.Backends.Hyperlinker.Parser as Hyperlinker import qualified Data.Map as M import Data.Map (Map) @@ -122,6 +124,8 @@ createInterface tm flags modMap instIfaceMap = do mkAliasMap dflags $ tm_renamed_source tm modWarn = moduleWarning dflags gre warnings + tokenizedSrc <- mkMaybeTokenizedSrc flags tm + return $! Interface { ifaceMod = mdl , ifaceOrigFilename = msHsFilePath ms @@ -145,7 +149,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceFamInstances = fam_instances , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = Nothing + , ifaceTokenizedSrc = tokenizedSrc } mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName @@ -862,6 +866,30 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs +mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule + -> ErrMsgGhc (Maybe [RichToken]) +mkMaybeTokenizedSrc flags tm + | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of + Just src -> do + tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src + return $ Just tokens + Nothing -> do + liftErrMsg . tell . pure $ concat + [ "Warning: Cannot hyperlink module \"" + , moduleNameString . ms_mod_name $ summary + , "\" because renamed source is not available" + ] + return Nothing + | otherwise = return Nothing + where + summary = pm_mod_summary . tm_parsed_module $ tm + +mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] +mkTokenizedSrc ms src = + Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc + where + rawSrc = readFile $ msHsFilePath ms + -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search -- cgit v1.2.3 From 62d44cd1d37d83fa93d169c2e5b5b758fcc231d6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 16:09:54 +0200 Subject: Create hyperlinker module and plug it into the Haddock pipeline. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock.hs | 4 ++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 +++++++++++++++++++++++++ haddock.cabal | 1 + 4 files changed, 31 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 109e5f95..6ffde976 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -82,6 +82,7 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3e58aba3..e45456ab 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle +import Haddock.Backends.Hyperlinker import Haddock.Interface import Haddock.Parser import Haddock.Types @@ -308,6 +309,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir + when (Flag_HyperlinkedSource `elem` flags) $ do + ppHyperlinkedSource odir libDir Nothing visibleIfaces + -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because -- package name and versions can no longer reliably be extracted in diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs new file mode 100644 index 00000000..88619474 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -0,0 +1,25 @@ +module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where + +import Haddock.Types +import Haddock.Backends.Hyperlinker.Renderer + +import GHC +import Text.XHtml hiding (()) +import System.Directory +import System.FilePath + +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] + -> IO () +ppHyperlinkedSource outdir libdir mstyle ifaces = do + createDirectoryIfMissing True (outdir "src") + mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + +ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mstyle $ tokens + Nothing -> return () + where + path = outdir "src" moduleSourceFile (ifaceMod iface) + +moduleSourceFile :: Module -> FilePath +moduleSourceFile = (++ ".html") . moduleNameString . moduleName diff --git a/haddock.cabal b/haddock.cabal index ed570f53..0aebefd8 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -101,6 +101,7 @@ executable haddock Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 6f16398a26a12d58b3ba7f1924e2b6b00e68f5f7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:20:37 +0200 Subject: Add support for providing custom CSS files for hyperlinked source. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/solarized.css | 55 +++++++++++++++++++++++++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 26 +++++++++--- haddock-api/src/Haddock/Options.hs | 6 +++ 5 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 haddock-api/resources/html/solarized.css diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6ffde976..14656994 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -18,6 +18,7 @@ stability: experimental data-dir: resources data-files: + html/solarized.css html/frames.html html/haddock-util.js html/Classic.theme/haskell_icon.gif diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css new file mode 100644 index 00000000..e4bff385 --- /dev/null +++ b/haddock-api/resources/html/solarized.css @@ -0,0 +1,55 @@ +body { + background-color: #fdf6e3; +} + +.hs-identifier { + color: #073642; +} + +.hs-identifier.hs-var { +} + +.hs-identifier.hs-type { + color: #5f5faf; +} + +.hs-keyword { + color: #af005f; +} + +.hs-string, .hs-char { + color: #cb4b16; +} + +.hs-number { + color: #268bd2; +} + +.hs-operator { + color: #d33682; +} + +.hs-glyph, .hs-special { + color: #dc322f; +} + +.hs-comment { + color: #8a8a8a; +} + +.hs-pragma { + color: #2aa198; +} + +.hs-cpp { + color: #859900; +} + +a:link, a:visited { + text-decoration: none; + border-bottom: 1px solid #eee8d5; +} + +a:hover { + background-color: #eee8d5; +} diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index e45456ab..698122e3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -244,6 +244,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags + opt_source_css = optSourceCssFile flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -310,7 +311,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir Nothing visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 88619474..66392a67 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -5,21 +5,35 @@ import Haddock.Backends.Hyperlinker.Renderer import GHC import Text.XHtml hiding (()) + +import Data.Maybe import System.Directory import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] -> IO () ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True (outdir "src") - mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + createDirectoryIfMissing True $ srcPath outdir + let cssFile = fromMaybe (defaultCssFile libdir) mstyle + copyFile cssFile $ srcPath outdir srcCssFile + mapM_ (ppHyperlinkedModuleSource outdir) ifaces -ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mstyle $ tokens +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens Nothing -> return () where - path = outdir "src" moduleSourceFile (ifaceMod iface) + mSrcCssFile = Just $ srcCssFile + path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath moduleSourceFile = (++ ".html") . moduleNameString . moduleName + +srcPath :: FilePath -> FilePath +srcPath outdir = outdir "src" + +srcCssFile :: FilePath +srcCssFile = "style.css" + +defaultCssFile :: FilePath -> FilePath +defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index c9d5688c..f84989ef 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -21,6 +21,7 @@ module Haddock.Options ( optContentsUrl, optIndexUrl, optCssFile, + optSourceCssFile, sourceUrls, wikiUrls, optDumpInterfaceFile, @@ -67,6 +68,7 @@ data Flag | Flag_LaTeX | Flag_LaTeXStyle String | Flag_HyperlinkedSource + | Flag_SourceCss String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -119,6 +121,8 @@ options backwardsCompat = "output for Hoogle; you may want --package-name and --package-version too", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", + Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") + "use custom CSS file instead of default one in hyperlinked source", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -242,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] optCssFile :: [Flag] -> Maybe FilePath optCssFile flags = optLast [ str | Flag_CSS str <- flags ] +optSourceCssFile :: [Flag] -> Maybe FilePath +optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ] sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) sourceUrls flags = -- cgit v1.2.3 From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:41:31 +0200 Subject: Add support for fancy highlighting upon hovering over identifier. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/highlight.js | 46 ++++++++++++++++++++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 10 ++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++---- 4 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 haddock-api/resources/html/highlight.js diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 14656994..216627cc 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -21,6 +21,7 @@ data-files: html/solarized.css html/frames.html html/haddock-util.js + html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js new file mode 100644 index 00000000..639cf5d5 --- /dev/null +++ b/haddock-api/resources/html/highlight.js @@ -0,0 +1,46 @@ + +var styleForRule = function (rule) { + var sheets = document.styleSheets; + for (var s = 0; s < sheets.length; s++) { + var rules = sheets[s].cssRules; + for (var r = 0; r < rules.length; r++) { + if (rules[r].selectorText == rule) { + return rules[r].style; + } + } + } +}; + +var highlight = function () { + var color = styleForRule("a:hover")["background-color"]; + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = color; + } + } +}; + +/* + * I have no idea what is the proper antonym for "highlight" in this + * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously + * so I like it. + */ +var lowlight = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = ""; + } + } +}; + +window.onload = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + links[i].onmouseover = highlight; + links[i].onmouseout = lowlight; + } +}; diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 66392a67..9337307c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True $ srcPath outdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcPath outdir srcCssFile + copyFile (libdir "html" highlightScript) $ + srcPath outdir highlightScript mapM_ (ppHyperlinkedModuleSource outdir) ifaces ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens + Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where - mSrcCssFile = Just $ srcCssFile + mCssFile = Just $ srcCssFile + mJsFile = Just $ highlightScript path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath @@ -35,5 +38,8 @@ srcPath outdir = outdir "src" srcCssFile :: FilePath srcCssFile = "style.css" +highlightScript :: FilePath +highlightScript = "highlight.js" + defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 70524759..6d6d2012 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -16,21 +16,28 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> [RichToken] -> Html -render css tokens = header css <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens body :: [RichToken] -> Html body = Html.body . Html.pre . mconcat . map richToken -header :: Maybe FilePath -> Html -header Nothing = Html.noHtml -header (Just css) = - Html.header $ Html.thelink Html.noHtml ! attrs +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs where - attrs = + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! [ Html.rel "stylesheet" - , Html.href css , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just jsFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src jsFile ] richToken :: RichToken -> Html -- cgit v1.2.3 From affd889d1b192d2cb9787c92202317b9e9401922 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 21:13:12 +0200 Subject: Make source hyperlinker generate output in apropriate directory. --- haddock-api/src/Haddock.hs | 10 ++++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 41 +++++++++++++++---------- haddock-api/src/Haddock/Utils.hs | 5 +++ 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 698122e3..01e4cd45 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -258,10 +258,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags + + srcModule' + | isJust srcModule = srcModule + | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl + | otherwise = Nothing + srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') + sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -311,7 +317,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 9337307c..2ed4dbdd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,45 +1,54 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types +import Haddock.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer -import GHC import Text.XHtml hiding (()) import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath + -> Maybe FilePath + -> SourceURLs + -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True $ srcPath outdir +ppHyperlinkedSource outdir libdir mstyle urls ifaces = do + createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle - copyFile cssFile $ srcPath outdir srcCssFile + copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ - srcPath outdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir) ifaces + srcdir highlightScript + mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + where + srcdir = srcPath outdir urls -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () +ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - path = srcPath outdir moduleSourceFile (ifaceMod iface) - -moduleSourceFile :: Module -> FilePath -moduleSourceFile = (++ ".html") . moduleNameString . moduleName + srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ + srcModUrl urls + path = outdir srcFile -srcPath :: FilePath -> FilePath -srcPath outdir = outdir "src" +srcPath :: FilePath -> SourceURLs -> FilePath +srcPath outdir urls = outdir takeDirectory (srcModUrl urls) srcCssFile :: FilePath -srcCssFile = "style.css" +srcCssFile = "srcstyle.css" highlightScript :: FilePath highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..78c78aca 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,6 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, + defaultModuleSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -277,6 +278,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r -- NB: '-' is legal in IDs, but we use it as the escape char +defaultModuleSourceUrl :: String +defaultModuleSourceUrl = "src/%{MODULE}.html" + + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From 844c09d0c1d724e0f0f0698654f2f85f5f58be19 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:24:57 +0200 Subject: Create module with hyperlinker utility functions. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 216627cc..7670f888 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs new file mode 100644 index 00000000..25ed942b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -0,0 +1,18 @@ +module Haddock.Backends.Hyperlinker.Utils + ( srcModUrl + , srcNameUrlMap + ) where + +import Haddock.Utils +import Haddock.Backends.Xhtml.Types + +import GHC + +import Data.Maybe +import Data.Map (Map) + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl + +srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath +srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap -- cgit v1.2.3 From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:41:07 +0200 Subject: Make external hyperlinks point to locations specified by source URLs. --- haddock-api/src/Haddock.hs | 7 ++- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 8 ++-- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 5 ++- 4 files changed, 44 insertions(+), 28 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 01e4cd45..3105edf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl | otherwise = Nothing - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + srcMap' + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey defaultNameSourceUrl srcMap + | otherwise = srcMap + -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 2ed4dbdd..6c66e0c6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,10 +1,10 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types -import Haddock.Utils import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) @@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens + Just tokens -> + writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile @@ -49,6 +50,3 @@ highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 6d6d2012..2df62938 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -16,11 +20,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html +render mcss mjs urls tokens = header mcss mjs <> body urls tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: SourceURLs -> [RichToken] -> Html +body urls = Html.body . Html.pre . mconcat . map (richToken urls) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -40,13 +44,13 @@ header mcss mjs = , Html.src jsFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: SourceURLs -> RichToken -> Html +richToken _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken urls (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink urls det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: SourceURLs -> TokenDetails -> Html -> Html +hyperlink urls details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalHyperlink mname (Just name) - where - mname = GHC.moduleName <$> GHC.nameModule_maybe name - Right name -> externalHyperlink (Just name) Nothing + else externalNameHyperlink urls name + Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html -externalHyperlink mmname miname content = - Html.anchor content ! [ Html.href $ path ++ anchor ] +externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html +externalNameHyperlink urls name = + case Map.lookup key $ srcNameUrlMap urls of + Just url -> externalNameHyperlink' url name + Nothing -> id where - path = fromMaybe "" $ modulePath <$> mmname - anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + key = GHC.modulePackageKey . GHC.nameModule $ name -modulePath :: GHC.ModuleName -> String -modulePath name = GHC.moduleNameString name ++ ".html" +externalNameHyperlink' :: String -> GHC.Name -> Html -> Html +externalNameHyperlink' url name content = + Html.anchor content ! [ Html.href $ href ] + where + mdl = GHC.nameModule name + href = spliceURL Nothing (Just mdl) (Just name) Nothing url + +externalModHyperlink :: GHC.ModuleName -> Html -> Html +externalModHyperlink _ = id -- TODO diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 78c78aca..047d9fd0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, + defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r defaultModuleSourceUrl :: String defaultModuleSourceUrl = "src/%{MODULE}.html" +defaultNameSourceUrl :: String +defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir -- cgit v1.2.3 From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 27 Jun 2015 18:03:56 +0200 Subject: Rewrite source generation to fixed links and directory structure. --- haddock-api/src/Haddock.hs | 11 +++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 29 +++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++------------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 48 +++++++++++++++----- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 14 +++--- haddock-api/src/Haddock/Utils.hs | 8 ---- 6 files changed, 85 insertions(+), 77 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3105edf5..d596c075 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcModule' - | isJust srcModule = srcModule - | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl - | otherwise = Nothing + | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat + | otherwise = srcModule srcMap' - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey defaultNameSourceUrl srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | otherwise = srcMap -- TODO: Get these from the interface files as with srcMap @@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 6c66e0c6..f197eaa3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,8 +1,9 @@ -module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where +module Haddock.Backends.Hyperlinker + ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Utils + ) where import Haddock.Types -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils @@ -14,36 +15,30 @@ import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> SourceURLs -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle urls ifaces = do +ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir) ifaces where - srcdir = srcPath outdir urls + srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () -ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens + writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ - srcModUrl urls - path = outdir srcFile - -srcPath :: FilePath -> SourceURLs -> FilePath -srcPath outdir urls = outdir takeDirectory (srcModUrl urls) + path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath -srcCssFile = "srcstyle.css" +srcCssFile = "style.css" highlightScript :: FilePath highlightScript = "highlight.js" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 2df62938..d8ea5ec7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List -import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -20,11 +17,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html -render mcss mjs urls tokens = header mcss mjs <> body urls tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens -body :: SourceURLs -> [RichToken] -> Html -body urls = Html.body . Html.pre . mconcat . map (richToken urls) +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -39,18 +36,18 @@ header mcss mjs = , Html.href cssFile ] js Nothing = Html.noHtml - js (Just jsFile) = Html.script Html.noHtml ! + js (Just scriptFile) = Html.script Html.noHtml ! [ Html.thetype "text/javascript" - , Html.src jsFile + , Html.src scriptFile ] -richToken :: SourceURLs -> RichToken -> Html -richToken _ (RichToken tok Nothing) = +richToken :: RichToken -> Html +richToken (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken urls (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink urls det $ content +richToken (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content = internalAnchor _ content = content externalAnchorIdent :: GHC.Name -> String -externalAnchorIdent = GHC.occNameString . GHC.nameOccName +externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: SourceURLs -> TokenDetails -> Html -> Html -hyperlink urls details = case rtkName details of +hyperlink :: TokenDetails -> Html -> Html +hyperlink details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink urls name + else externalNameHyperlink name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html -externalNameHyperlink urls name = - case Map.lookup key $ srcNameUrlMap urls of - Just url -> externalNameHyperlink' url name - Nothing -> id +externalNameHyperlink :: GHC.Name -> Html -> Html +externalNameHyperlink name content = + Html.anchor content ! [ Html.href href ] where - key = GHC.modulePackageKey . GHC.nameModule $ name - -externalNameHyperlink' :: String -> GHC.Name -> Html -> Html -externalNameHyperlink' url name content = - Html.anchor content ! [ Html.href $ href ] - where - mdl = GHC.nameModule name - href = spliceURL Nothing (Just mdl) (Just name) Nothing url + href = hypSrcModuleNameUrl (GHC.nameModule name) name externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ = id -- TODO +externalModHyperlink mdl content = + Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] + diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 25ed942b..9ba8446d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,18 +1,46 @@ module Haddock.Backends.Hyperlinker.Utils - ( srcModUrl - , srcNameUrlMap + ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' + , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl + , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where -import Haddock.Utils -import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import GHC +import System.FilePath.Posix (()) -import Data.Maybe -import Data.Map (Map) -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl +hypSrcDir :: FilePath +hypSrcDir = "src" -srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath -srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap +hypSrcModuleFile :: Module -> FilePath +hypSrcModuleFile = hypSrcModuleFile' . moduleName + +hypSrcModuleFile' :: ModuleName -> FilePath +hypSrcModuleFile' mdl = spliceURL' + Nothing (Just mdl) Nothing Nothing moduleFormat + +hypSrcModuleUrl :: Module -> String +hypSrcModuleUrl = hypSrcModuleFile + +hypSrcModuleUrl' :: ModuleName -> String +hypSrcModuleUrl' = hypSrcModuleFile' + +hypSrcNameUrl :: Name -> String +hypSrcNameUrl name = spliceURL + Nothing Nothing (Just name) Nothing nameFormat + +hypSrcModuleNameUrl :: Module -> Name -> String +hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + +hypSrcModuleUrlFormat :: String +hypSrcModuleUrlFormat = hypSrcDir moduleFormat + +hypSrcModuleNameUrlFormat :: String +hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat + +moduleFormat :: String +moduleFormat = "%{MODULE}.html" + +nameFormat :: String +nameFormat = "%{NAME}" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index cbcbbd6d..36ecf863 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils ( renderToString, namedAnchor, linkedAnchor, - spliceURL, + spliceURL, spliceURL', groupId, (<+>), (<=>), char, @@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils ( ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe @@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) +import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run +spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) + + +spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> "" - Just m -> moduleString m + Just m -> moduleNameString m (name, kind) = case maybe_name of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 047d9fd0..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,6 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -278,13 +277,6 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r -- NB: '-' is legal in IDs, but we use it as the escape char -defaultModuleSourceUrl :: String -defaultModuleSourceUrl = "src/%{MODULE}.html" - -defaultNameSourceUrl :: String -defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" - - ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:00:55 +0200 Subject: Add basic support for cross-package hyperlink generation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 ++++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 42 +++++++++++++--------- 3 files changed, 40 insertions(+), 29 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d596c075..caaa1eef 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f197eaa3..f2caa2c1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) +import GHC import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath - -> Maybe FilePath - -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath + -> PackageKey -> SrcMap -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do +ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of - Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: FilePath + -> PackageKey -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pkg srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . showHtml . render' $ tokens + Nothing -> return () where - mCssFile = Just $ srcCssFile - mJsFile = Just $ highlightScript + render' = render (Just srcCssFile) (Just highlightScript) pkg srcs path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d8ea5ec7..b05a5b8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,5 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where +import Haddock.Types import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils @@ -8,20 +9,25 @@ import qualified GHC import qualified Name as GHC import qualified Unique as GHC +import System.FilePath.Posix (()) + import Data.List import Data.Maybe import Data.Monoid +import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath + -> GHC.PackageKey -> SrcMap -> [RichToken] + -> Html +render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html +body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -41,13 +47,13 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html +richToken _ _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken pkg srcs (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html +hyperlink pkg srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink name + else externalNameHyperlink pkg srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.Name -> Html -> Html -externalNameHyperlink name content = - Html.anchor content ! [ Html.href href ] +externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink pkg srcs name content + | namePkg == pkg = Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + [ Html.href $ path hypSrcModuleNameUrl mdl name ] + | otherwise = content where - href = hypSrcModuleNameUrl (GHC.nameModule name) name + mdl = GHC.nameModule name + namePkg = GHC.modulePackageKey mdl externalModHyperlink :: GHC.ModuleName -> Html -> Html externalModHyperlink mdl content = Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] - -- cgit v1.2.3 From 98cb99c2398a2e2b4467da0a1755d24422384f14 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:33:03 +0200 Subject: Disable generating hyperlinks for module references. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b05a5b8a..89d9b60d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -123,6 +123,13 @@ externalNameHyperlink pkg srcs name content mdl = GHC.nameModule name namePkg = GHC.modulePackageKey mdl +-- TODO: Implement module hyperlinks. +-- +-- Unfortunately, 'ModuleName' is not enough to provide viable cross-package +-- hyperlink. And the problem is that GHC AST does not have other information +-- on imported modules, so for the time being, we do not provide such reference +-- either. externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink mdl content = - Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink _ content = + content + --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] -- cgit v1.2.3 From 4a6b6c18dbb6542b64f13e4f51cc0447df15a175 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:45:29 +0200 Subject: Make Haddock generate source for all interfaces (also hidden ones). --- haddock-api/src/Haddock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index caaa1eef..c76966fc 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because -- cgit v1.2.3 From 311b3cc529097ef83a8212439dafcabb86534c62 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 22:28:00 +0200 Subject: Prevent source parser from throwing exception when lexing fails. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 6e195dba..bab5ba0a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -63,7 +63,9 @@ chunk str@(c:_) chunk str | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = chunk' $ head $ lex str + | otherwise = case lex str of + (tok:_) -> chunk' tok + [] -> [str] where chunk' (c, rest) = c:(chunk rest) -- cgit v1.2.3 From 6cf5e45135ad48f140a76054b38e13eb83491d2a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 23:13:05 +0200 Subject: Implement workaround for Chrome highlighting issues. --- haddock-api/resources/html/highlight.js | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js index 639cf5d5..a538feae 100644 --- a/haddock-api/resources/html/highlight.js +++ b/haddock-api/resources/html/highlight.js @@ -3,6 +3,10 @@ var styleForRule = function (rule) { var sheets = document.styleSheets; for (var s = 0; s < sheets.length; s++) { var rules = sheets[s].cssRules; + if (rules === null) { + return null; + } + for (var r = 0; r < rules.length; r++) { if (rules[r].selectorText == rule) { return rules[r].style; @@ -12,7 +16,13 @@ var styleForRule = function (rule) { }; var highlight = function () { - var color = styleForRule("a:hover")["background-color"]; + /* + * Chrome for security reasons disallows to read .cssRules property. + * So, we are forced to pick some color and set it as a highlight. + */ + var style = styleForRule("a:hover"); + var color = style !== null ? style["background-color"] : "#808080"; + var links = document.getElementsByTagName('a'); for (var i = 0; i < links.length; i++) { var that = links[i]; -- cgit v1.2.3 From 5a86381db3d73b4b68fdaae5c150a84e91e80c09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 16:10:03 +0200 Subject: Make hyperlinker generate correct anchors for data constructors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 275f10e9..c32bb722 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -107,17 +107,22 @@ binds = -- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) - [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everything (<|>) fun ] where - typ (GHC.L _ t) = - let (GHC.L sspan name) = GHC.tcdLName t - in (sspan, RtkDecl name) + typ (GHC.L _ t) = case t of + GHC.DataDecl (GHC.L sspan name) _ defn _ -> + [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn) + _ -> + let (GHC.L sspan name) = GHC.tcdLName t + in pure (sspan, RtkDecl name) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty + con (GHC.L _ t) = flip map (GHC.con_names t) $ + \(GHC.L sspan name) -> (sspan, RtkDecl name) -- | Obtain details map for import declarations. -- -- cgit v1.2.3 From 46b1520fcc8ef56825bd42ecf1c1fa8ec899ee58 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 17:33:59 +0200 Subject: Make hyperlinker generate anchors for record field declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c32bb722..5efcd2ed 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -112,17 +112,19 @@ decls (group, _, _, _) = concatMap ($ group) ] where typ (GHC.L _ t) = case t of - GHC.DataDecl (GHC.L sspan name) _ defn _ -> - [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn) - _ -> - let (GHC.L sspan name) = GHC.tcdLName t - in pure (sspan, RtkDecl name) + GHC.DataDecl name _ defn _ -> + [decl name] ++ concatMap con (GHC.dd_cons defn) + _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty - con (GHC.L _ t) = flip map (GHC.con_names t) $ - \(GHC.L sspan name) -> (sspan, RtkDecl name) + con (GHC.L _ t) = + map decl (GHC.con_names t) ++ everything (<|>) fld t + fld term = case cast term of + Just field -> map decl $ GHC.cd_fld_names field + Nothing -> empty + decl (GHC.L sspan name) = (sspan, RtkDecl name) -- | Obtain details map for import declarations. -- -- cgit v1.2.3 From 671e7dc60266d1e0fdabd34956719961c1333fb3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 20:33:18 +0200 Subject: Fix issue with hyperlink highlight styling in Chrome browser. --- haddock-api/resources/html/highlight.js | 57 ++++++++------------------------ haddock-api/resources/html/solarized.css | 2 +- 2 files changed, 15 insertions(+), 44 deletions(-) diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js index a538feae..1e903bd0 100644 --- a/haddock-api/resources/html/highlight.js +++ b/haddock-api/resources/html/highlight.js @@ -1,48 +1,19 @@ -var styleForRule = function (rule) { - var sheets = document.styleSheets; - for (var s = 0; s < sheets.length; s++) { - var rules = sheets[s].cssRules; - if (rules === null) { - return null; - } +var highlight = function (on) { + return function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; - for (var r = 0; r < rules.length; r++) { - if (rules[r].selectorText == rule) { - return rules[r].style; + if (this.href != that.href) { + continue; } - } - } -}; - -var highlight = function () { - /* - * Chrome for security reasons disallows to read .cssRules property. - * So, we are forced to pick some color and set it as a highlight. - */ - var style = styleForRule("a:hover"); - var color = style !== null ? style["background-color"] : "#808080"; - - var links = document.getElementsByTagName('a'); - for (var i = 0; i < links.length; i++) { - var that = links[i]; - if (this.href == that.href) { - that.style["background-color"] = color; - } - } -}; -/* - * I have no idea what is the proper antonym for "highlight" in this - * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously - * so I like it. - */ -var lowlight = function () { - var links = document.getElementsByTagName('a'); - for (var i = 0; i < links.length; i++) { - var that = links[i]; - if (this.href == that.href) { - that.style["background-color"] = ""; + if (on) { + that.classList.add("hover-highlight"); + } else { + that.classList.remove("hover-highlight"); + } } } }; @@ -50,7 +21,7 @@ var lowlight = function () { window.onload = function () { var links = document.getElementsByTagName('a'); for (var i = 0; i < links.length; i++) { - links[i].onmouseover = highlight; - links[i].onmouseout = lowlight; + links[i].onmouseover = highlight(true); + links[i].onmouseout = highlight(false); } }; diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css index e4bff385..e83dc5ec 100644 --- a/haddock-api/resources/html/solarized.css +++ b/haddock-api/resources/html/solarized.css @@ -50,6 +50,6 @@ a:link, a:visited { border-bottom: 1px solid #eee8d5; } -a:hover { +a:hover, a.hover-highlight { background-color: #eee8d5; } -- cgit v1.2.3 From d6cfd266b30066a5452514b26e50b740104a982b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:00:54 +0200 Subject: Add support for hyperlinking constructor names in patters. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 5efcd2ed..fd3f2f1e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -102,6 +102,8 @@ binds = pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind name) + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) -> + pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for top-level declarations. -- cgit v1.2.3 From a1d3cb1d86340cd670e50f88e1cb8bf4a4e64f7b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:15:26 +0200 Subject: Add support for hyperlinking field names in record patterns. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index fd3f2f1e..3b0e0f44 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -102,7 +102,11 @@ binds = pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind name) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> + [(sspan, RtkVar name)] ++ everything (<|>) rec recs + _ -> empty + rec term = case cast term of + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> pure (sspan, RtkVar name) _ -> empty -- cgit v1.2.3 From 7d269444ea9c55a2b364ead45fe06d435fa078b2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:41:10 +0200 Subject: Add support for hyperlinking field names in record expressions. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3b0e0f44..c41b5e5f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -69,11 +69,17 @@ enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = - everything (<|>) var + everything (<|>) (var `combine` rec) where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> pure (sspan, RtkVar name) + (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) -> + pure (sspan, RtkVar name) + _ -> empty + rec term = case cast term of + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> + pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for types. -- cgit v1.2.3 From 6bebd572bc673d10ed68096f935cdc5a9d1839b5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:58:08 +0200 Subject: Make hyperlinker respect pretty-printer flag and add documentation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 30 +++++++++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index c76966fc..02e19531 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f2caa2c1..1fadef49 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -14,35 +14,51 @@ import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> PackageKey -> SrcMap -> [Interface] + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +ppHyperlinkedSource :: FilePath -- ^ Output directory + -> FilePath -- ^ Resource directory + -> Maybe FilePath -- ^ Custom CSS file path + -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> PackageKey -- ^ Package for which we create source + -> SrcMap -- ^ Paths to external sources + -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> PackageKey -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . showHtml . render' $ tokens + Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) +-- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" +-- | Name of highlight script in output and resource directory. highlightScript :: FilePath highlightScript = "highlight.js" +-- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" -- cgit v1.2.3 From fe22edadb6071e0b8e83c2ddff21d28bbe922a68 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 22:00:14 +0200 Subject: Unexpose hyperlinker modules in Cabal configuration. --- haddock-api/haddock-api.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 7670f888..23c4497a 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -59,9 +59,6 @@ library exposed-modules: Documentation.Haddock - Haddock.Backends.Hyperlinker.Parser - Haddock.Backends.Hyperlinker.Renderer - Haddock.Backends.Hyperlinker.Ast other-modules: Haddock @@ -85,6 +82,9 @@ library Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types -- cgit v1.2.3 From d44fc5b2b40e26e76d2fe7ac0a47bea84154cf67 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 00:00:33 +0200 Subject: Setup HSpec framework for Haddock API package. --- haddock-api/haddock-api.cabal | 31 ++++++++++++++++++++++ .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 17 ++++++++++++ haddock-api/test/Spec.hs | 1 + 3 files changed, 49 insertions(+) create mode 100644 haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs create mode 100644 haddock-api/test/Spec.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 23c4497a..56889e66 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -96,6 +96,37 @@ library Haddock.Convert Paths_haddock_api +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Spec.hs + ghc-options: -Wall + + hs-source-dirs: + test + , src + + other-modules: + Haddock.Backends.Hyperlinker.ParserSpec + + build-depends: + base >= 4.3 && < 4.9 + , bytestring + , filepath + , directory + , containers + , deepseq + , array + , xhtml >= 3000.2 && < 3000.3 + , Cabal >= 1.10 + , ghc >= 7.10 && < 7.10.2 + + , ghc-paths + , haddock-library == 1.2.* + + , hspec + , QuickCheck == 2.* + source-repository head type: git location: https://github.com/haskell/haddock.git diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs new file mode 100644 index 00000000..c85fa47e --- /dev/null +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -0,0 +1,17 @@ +module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where + + +import Test.Hspec + +import Haddock.Backends.Hyperlinker.Parser + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "parse" parseSpec + +parseSpec :: Spec +parseSpec = return () diff --git a/haddock-api/test/Spec.hs b/haddock-api/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/haddock-api/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -- cgit v1.2.3 From f3d1f3cbd6e99f5d477a78e05c13b65b9e8b3fae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 00:49:17 +0200 Subject: Add basic tests related to comment parsing. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 37 +++++++++++++++++++++- 2 files changed, 37 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index bab5ba0a..019075a1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -38,7 +38,7 @@ data TokenType | TkCpp | TkPragma | TkUnknown - deriving (Eq) + deriving (Show, Eq) -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index c85fa47e..d5964224 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -9,9 +9,44 @@ import Haddock.Backends.Hyperlinker.Parser main :: IO () main = hspec spec + spec :: Spec spec = do describe "parse" parseSpec + parseSpec :: Spec -parseSpec = return () +parseSpec = do + + context "when parsing single-line comments" $ do + + it "should ignore content until the end of line" $ + "-- some very simple comment\nidentifier" + `shouldParseTo` + [TkComment, TkSpace, TkIdentifier] + + it "should allow endline escaping" $ + "-- first line\\\nsecond line\\\nand another one" + `shouldParseTo` + [TkComment] + + context "when parsing multi-line comments" $ do + + it "should support nested comments" $ + "{- comment {- nested -} still comment -} {- next comment -}" + `shouldParseTo` + [TkComment, TkSpace, TkComment] + + it "should distinguish compiler pragma" $ + "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" + `shouldParseTo` + [TkComment, TkPragma, TkComment] + + it "should recognize preprocessor directives" $ do + "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] + "x # y" `shouldParseTo` + [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier] + + +shouldParseTo :: String -> [TokenType] -> Expectation +str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens -- cgit v1.2.3 From 86ccbbf208fad2b27d2d76d9a32a80b452274d2e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 12:41:08 +0200 Subject: Add tests related to parsing basic language constructs. --- .../test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index d5964224..fa880a37 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -47,6 +47,26 @@ parseSpec = do "x # y" `shouldParseTo` [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier] + it "should distinguish basic language constructs" $ do + "(* 2) <$> (\"abc\", foo)" `shouldParseTo` + [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial + , TkSpace, TkOperator, TkSpace + , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial + ] + "let foo' = foo in foo' + foo'" `shouldParseTo` + [ TkKeyword, TkSpace, TkIdentifier + , TkSpace, TkGlyph, TkSpace + , TkIdentifier, TkSpace, TkKeyword, TkSpace + , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier + ] + "square x = y^2 where y = x" `shouldParseTo` + [ TkIdentifier, TkSpace, TkIdentifier + , TkSpace, TkGlyph, TkSpace + , TkIdentifier, TkOperator, TkNumber + , TkSpace, TkKeyword, TkSpace + , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier + ] + shouldParseTo :: String -> [TokenType] -> Expectation str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens -- cgit v1.2.3 From 2426a64771339efb4a776799d9bf593d6b8d09a3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 15:54:30 +0200 Subject: Add simple tests for do-notation parsing. --- .../test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index fa880a37..5e69b446 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -67,6 +67,24 @@ parseSpec = do , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + it "should parse do-notation syntax" $ do + "do { foo <- getLine; putStrLn foo }" `shouldParseTo` + [ TkKeyword, TkSpace, TkSpecial, TkSpace + , TkIdentifier, TkSpace, TkGlyph, TkSpace + , TkIdentifier, TkSpecial, TkSpace + , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial + ] + + unlines + [ "do" + , " foo <- getLine" + , " putStrLn foo" + ] `shouldParseTo` + [ TkKeyword, TkSpace, TkIdentifier + , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace + , TkIdentifier, TkSpace, TkIdentifier, TkSpace + ] + shouldParseTo :: String -> [TokenType] -> Expectation str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens -- cgit v1.2.3 From 5ddb425bbdc29efdd314ffc18db6c8e6c3609d24 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 23:58:24 +0200 Subject: Add very simple QuickCheck properties for source parser spec. --- haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 5e69b446..38cdbc87 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -2,6 +2,7 @@ module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where import Test.Hspec +import Test.QuickCheck import Haddock.Backends.Hyperlinker.Parser @@ -18,6 +19,12 @@ spec = do parseSpec :: Spec parseSpec = do + it "is total" $ + property $ \src -> length (parse src) `shouldSatisfy` (>= 0) + + it "retains file layout" $ + property $ \src -> concatMap tkValue (parse src) == src + context "when parsing single-line comments" $ do it "should ignore content until the end of line" $ -- cgit v1.2.3 From 5f13457a8e31f424d797f721e93434e09bc9140a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 19:38:21 +0200 Subject: Create simple test runner for hyperlinker tests. --- hypsrc-test/run.hs | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100755 hypsrc-test/run.hs diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs new file mode 100755 index 00000000..0b97a075 --- /dev/null +++ b/hypsrc-test/run.hs @@ -0,0 +1,119 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE CPP #-} + + +import Control.Applicative +import Control.Monad + +import Data.List +import Data.Maybe + +import System.IO +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Process + +import Distribution.Verbosity +import Distribution.Simple.Utils hiding (die) + + +baseDir, rootDir :: FilePath +baseDir = takeDirectory __FILE__ +rootDir = baseDir ".." + +srcDir, refDir, outDir :: FilePath +srcDir = baseDir "src" +refDir = baseDir "ref" +outDir = baseDir "out" + +haddockPath :: FilePath +haddockPath = rootDir "dist" "build" "haddock" "haddock" + + +main :: IO () +main = do + haddockAvailable <- doesFileExist haddockPath + unless haddockAvailable $ die "Haddock exectuable not available" + + (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs + let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args + mods' <- map (srcDir ) <$> if "--all" `elem` args || "-a" `elem` args + then getAllSrcModules + else return mods + + putHaddockVersion + putGhcVersion + + putStrLn "Running tests..." + runHaddock $ + [ "--odir=" ++ outDir + , "--no-warnings" + , "--hyperlinked-source" + ] ++ args' ++ mods' + + forM_ mods' $ check True + + +check :: Bool -> FilePath -> IO () +check strict mdl = do + hasReference <- doesFileExist refFile + if hasReference + then do + out <- readFile outFile + ref <- readFile refFile + if out == ref + then putStrLn $ "Pass: " ++ mdl + else do + putStrLn $ "Fail: " ++ mdl + diff refFile outFile + when strict $ die "Aborting further tests." + else do + putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" + where + refFile = refDir takeBaseName mdl ++ ".html" + outFile = outDir takeBaseName mdl ++ ".html" + + +diff :: FilePath -> FilePath -> IO () +diff fileA fileB = do + colorDiffPath <- findProgramLocation silent "colordiff" + let cmd = fromMaybe "diff" colorDiffPath + + result <- system $ cmd ++ " " ++ fileA ++ " " ++ fileB + unless (result == ExitSuccess) $ die "Failed to run `diff` command." + + +getAllSrcModules :: IO [FilePath] +getAllSrcModules = + filter isValid <$> getDirectoryContents srcDir + where + isValid = (== ".hs") . takeExtension + + +putHaddockVersion :: IO () +putHaddockVersion = do + putStrLn "Haddock version:" + runHaddock ["--version"] + putStrLn "" + + +putGhcVersion :: IO () +putGhcVersion = do + putStrLn "GHC version:" + runHaddock ["--ghc-version"] + putStrLn "" + + +runHaddock :: [String] -> IO () +runHaddock args = do + env <- Just <$> getEnvironment + handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing + waitForSuccess handle $ "Failed to invoke haddock with " ++ show args + + +waitForSuccess :: ProcessHandle -> String -> IO () +waitForSuccess handle msg = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ die msg -- cgit v1.2.3 From 3b6cbe3ac03d03ea9824770a54868e41d8cf13b6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 19:48:24 +0200 Subject: Add test case for basic identifier hyperlinking. --- hypsrc-test/src/Identifiers.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 hypsrc-test/src/Identifiers.hs diff --git a/hypsrc-test/src/Identifiers.hs b/hypsrc-test/src/Identifiers.hs new file mode 100644 index 00000000..e2d6223d --- /dev/null +++ b/hypsrc-test/src/Identifiers.hs @@ -0,0 +1,27 @@ +module Identifiers where + + +foo, bar, baz :: Int -> Int -> Int +foo x y = x + x * bar y x * y + y +bar x y = y + x - baz x y - x + y +baz x y = x * y * y * y * x + +quux :: Int -> Int +quux x = foo (bar x x) (bar x x) + +norf :: Int -> Int -> Int -> Int +norf x y z + | x < 0 = quux x + | y < 0 = quux y + | z < 0 = quux z + | otherwise = norf (-x) (-y) (-z) + + +main :: IO () +main = do + putStrLn . show $ foo x y + putStrLn . show $ quux z + where + x = 10 + y = 20 + z = 30 -- cgit v1.2.3 From 15ac1a816a9875591febcf678bbf914a11e5068f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:00:32 +0200 Subject: Add test case for operator hyperlinking. --- hypsrc-test/src/Operators.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 hypsrc-test/src/Operators.hs diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs new file mode 100644 index 00000000..bc76c2d3 --- /dev/null +++ b/hypsrc-test/src/Operators.hs @@ -0,0 +1,18 @@ +module Operators where + + +(+++) :: [a] -> [a] -> [a] +a +++ b = a ++ b ++ a + +($$$) :: [a] -> [a] -> [a] +a $$$ b = b +++ a + +(***) :: [a] -> [a] -> [a] +(***) a [] = a +(***) a (_:b) = a +++ (a *** b) + +(*/\*) :: [[a]] -> [a] -> [a] +a */\* b = concatMap (*** b) a + +(**/\**) :: [[a]] -> [[a]] -> [[a]] +a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) -- cgit v1.2.3 From 95dfb7ab280d69d2bc2eb7f9ab0c4c3deae53cc2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:10:08 +0200 Subject: Add test case for constructor hyperlinking. --- hypsrc-test/src/Constructors.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 hypsrc-test/src/Constructors.hs diff --git a/hypsrc-test/src/Constructors.hs b/hypsrc-test/src/Constructors.hs new file mode 100644 index 00000000..c52bdc72 --- /dev/null +++ b/hypsrc-test/src/Constructors.hs @@ -0,0 +1,27 @@ +module Constructors where + + +data Foo + = Bar + | Baz + | Quux Foo Int + +newtype Norf = Norf (Foo, [Foo], Foo) + + +bar, baz, quux :: Foo +bar = Bar +baz = Baz +quux = Quux quux 0 + + +unfoo :: Foo -> Int +unfoo Bar = 0 +unfoo Baz = 0 +unfoo (Quux foo n) = 42 * n + unfoo foo + + +unnorf :: Norf -> [Foo] +unnorf (Norf (Bar, xs, Bar)) = xs +unnorf (Norf (Baz, xs, Baz)) = reverse xs +unnorf _ = undefined -- cgit v1.2.3 From 354d3296371099bad2729cf7b5445d23a107c6c5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:18:42 +0200 Subject: Add test case for record expressions and patterns hyperlinking. --- hypsrc-test/src/Records.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 hypsrc-test/src/Records.hs diff --git a/hypsrc-test/src/Records.hs b/hypsrc-test/src/Records.hs new file mode 100644 index 00000000..4118e296 --- /dev/null +++ b/hypsrc-test/src/Records.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Records where + + +data Point = Point + { x :: !Int + , y :: !Int + } + + +point :: Int -> Int -> Point +point x y = Point { x = x, y = y } + + +lengthSqr :: Point -> Int +lengthSqr (Point { x = x, y = y }) = x * x + y * y + +lengthSqr' :: Point -> Int +lengthSqr' (Point { x, y }) = y * y + x * x + + +translateX, translateY :: Point -> Int -> Point +translateX p d = p { x = x p + d } +translateY p d = p { y = y p + d } -- cgit v1.2.3 From 9dfb3f87cf71042eb883e228a8c6c7f25c743118 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 20:30:37 +0200 Subject: Add test case for literal syntax highlighting. --- hypsrc-test/src/Literals.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 hypsrc-test/src/Literals.hs diff --git a/hypsrc-test/src/Literals.hs b/hypsrc-test/src/Literals.hs new file mode 100644 index 00000000..997b6615 --- /dev/null +++ b/hypsrc-test/src/Literals.hs @@ -0,0 +1,17 @@ +module Literals where + + +str :: String +str = "str literal" + +num :: Num a => a +num = 0 + 1 + 1010011 * 41231 + 12131 + +frac :: Fractional a => a +frac = 42.0000001 + +list :: [[[[a]]]] +list = [[], [[]], [[[]]]] + +pair :: ((), ((), (), ()), ()) +pair = ((), ((), (), ()), ()) -- cgit v1.2.3 From cddb70986db0f34427cf74cc93352b1ed10ed56b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:18:46 +0200 Subject: Add hyperlinker test runner to .cabal and .gitignore files. --- .gitignore | 1 + haddock.cabal | 9 +++++++++ 2 files changed, 10 insertions(+) diff --git a/.gitignore b/.gitignore index f07c758d..3c9798c1 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ /haddock-api/dist/ /haddock-library/dist/ /html-test/out/ +/hypsrc-test/out/ /latex-test/out/ /doc/haddock diff --git a/haddock.cabal b/haddock.cabal index 0aebefd8..01e6a558 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -29,6 +29,8 @@ extra-source-files: haddock-api/src/haddock.sh html-test/src/*.hs html-test/ref/*.html + hypsrc-test/src/*.hs + hypsrc-test/ref/*.html latex-test/src/Simple/*.hs latex-test/ref/Simple/*.tex latex-test/ref/Simple/*.sty @@ -120,6 +122,13 @@ test-suite html-test hs-source-dirs: html-test build-depends: base, directory, process, filepath, Cabal +test-suite hypsrc-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: run.hs + hs-source-dirs: hypsrc-test + build-depends: base, directory, process, filepath, Cabal + test-suite latex-test type: exitcode-stdio-1.0 default-language: Haskell2010 -- cgit v1.2.3 From beab75b0d28117c9b1e56d3a88e8aac70d5bd0b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:23:31 +0200 Subject: Adapt hyperlinker test runner to have the same interface as HTML one. --- hypsrc-test/run.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 0b97a075..549f33f7 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -39,9 +39,9 @@ main = do (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args - mods' <- map (srcDir ) <$> if "--all" `elem` args || "-a" `elem` args - then getAllSrcModules - else return mods + mods' <- map (srcDir ) <$> case args of + [] -> getAllSrcModules + _ -> return $ map (++ ".hs") mods putHaddockVersion putGhcVersion -- cgit v1.2.3 From 5da90733ea03cdb935478e0665b45fe44c116728 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 22:28:12 +0200 Subject: Fix hyperlinker test runner file paths and add pretty-printing option. --- hypsrc-test/run.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 549f33f7..e9a38c0c 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -20,13 +20,15 @@ import Distribution.Simple.Utils hiding (die) baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ +baseDir = takeDirectory __FILE__ rootDir = baseDir ".." -srcDir, refDir, outDir :: FilePath +srcDir, refDir, outDir, refDir', outDir' :: FilePath srcDir = baseDir "src" refDir = baseDir "ref" outDir = baseDir "out" +refDir' = refDir "src" +outDir' = outDir "src" haddockPath :: FilePath haddockPath = rootDir "dist" "build" "haddock" "haddock" @@ -51,6 +53,7 @@ main = do [ "--odir=" ++ outDir , "--no-warnings" , "--hyperlinked-source" + , "--pretty-html" ] ++ args' ++ mods' forM_ mods' $ check True @@ -72,8 +75,8 @@ check strict mdl = do else do putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" where - refFile = refDir takeBaseName mdl ++ ".html" - outFile = outDir takeBaseName mdl ++ ".html" + refFile = refDir' takeBaseName mdl ++ ".html" + outFile = outDir' takeBaseName mdl ++ ".html" diff :: FilePath -> FilePath -> IO () -- cgit v1.2.3 From 40d0a050c81ff21949fc7eeede4e0dbb3b1d7c98 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 22:29:34 +0200 Subject: Add reference files for hyperlinker test cases. --- hypsrc-test/ref/src/Constructors.html | 536 +++++++++++++++++++++++ hypsrc-test/ref/src/Identifiers.html | 800 ++++++++++++++++++++++++++++++++++ hypsrc-test/ref/src/Literals.html | 382 ++++++++++++++++ hypsrc-test/ref/src/Operators.html | 655 ++++++++++++++++++++++++++++ hypsrc-test/ref/src/Records.html | 646 +++++++++++++++++++++++++++ 5 files changed, 3019 insertions(+) create mode 100644 hypsrc-test/ref/src/Constructors.html create mode 100644 hypsrc-test/ref/src/Identifiers.html create mode 100644 hypsrc-test/ref/src/Literals.html create mode 100644 hypsrc-test/ref/src/Operators.html create mode 100644 hypsrc-test/ref/src/Records.html diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html new file mode 100644 index 00000000..713a85f0 --- /dev/null +++ b/hypsrc-test/ref/src/Constructors.html @@ -0,0 +1,536 @@ + +
    module Constructors where
+
+
+data Foo
+    = Bar
+    | Baz
+    | Quux Foo Int
+
+newtype Norf = Norf (Foo, [Foo], Foo)
+
+
+bar, baz, quux :: Foo
+bar = Bar
+baz = Baz
+quux = Quux quux 0
+
+
+unfoo :: Foo -> Int
+unfoo Bar = 0
+unfoo Baz = 0
+unfoo (Quux foo n) = 42 * n + unfoo foo
+
+
+unnorf :: Norf -> [Foo]
+unnorf (Norf (Bar, xs, Bar)) = xs
+unnorf (Norf (Baz, xs, Baz)) = reverse xs
+unnorf _ = undefined
+
    diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html new file mode 100644 index 00000000..ee21791f --- /dev/null +++ b/hypsrc-test/ref/src/Identifiers.html @@ -0,0 +1,800 @@ + +
    module Identifiers where
+
+
+foo, bar, baz :: Int -> Int -> Int
+foo x y = x + x * bar y x * y + y
+bar x y = y + x - baz x y - x + y
+baz x y = x * y * y * y * x
+
+quux :: Int -> Int
+quux x = foo (bar x x) (bar x x)
+
+norf :: Int -> Int -> Int -> Int
+norf x y z
+    | x < 0 = quux x
+    | y < 0 = quux y
+    | z < 0 = quux z
+    | otherwise = norf (-x) (-y) (-z)
+
+
+main :: IO ()
+main = do
+    putStrLn . show $ foo x y
+    putStrLn . show $ quux z
+  where
+    x = 10
+    y = 20
+    z = 30
+
    diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html new file mode 100644 index 00000000..f8549642 --- /dev/null +++ b/hypsrc-test/ref/src/Literals.html @@ -0,0 +1,382 @@ + +
    module Literals where
+
+
+str :: String
+str = "str literal"
+
+num :: Num a => a
+num = 0 + 1 + 1010011 * 41231 + 12131
+
+frac :: Fractional a => a
+frac = 42.0000001
+
+list :: [[[[a]]]]
+list = [[], [[]], [[[]]]]
+
+pair :: ((), ((), (), ()), ())
+pair = ((), ((), (), ()), ())
+
    diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html new file mode 100644 index 00000000..04fe4ee4 --- /dev/null +++ b/hypsrc-test/ref/src/Operators.html @@ -0,0 +1,655 @@ + +
    module Operators where
+
+
+(+++) :: [a] -> [a] -> [a]
+a +++ b = a ++ b ++ a
+
+($$$) :: [a] -> [a] -> [a]
+a $$$ b = b +++ a
+
+(***) :: [a] -> [a] -> [a]
+(***) a [] = a
+(***) a (_:b) = a +++ (a *** b)
+
+(*/\*) :: [[a]] -> [a] -> [a]
+a */\* b = concatMap (*** b) a
+
+(**/\**) :: [[a]] -> [[a]] -> [[a]]
+a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b)
+
    diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html new file mode 100644 index 00000000..b982c5b1 --- /dev/null +++ b/hypsrc-test/ref/src/Records.html @@ -0,0 +1,646 @@ + +
    {-# LANGUAGE NamedFieldPuns #-}
+
+module Records where
+
+
+data Point = Point
+    { x :: !Int
+    , y :: !Int
+    }
+
+
+point :: Int -> Int -> Point
+point x y = Point { x = x, y = y }
+
+
+lengthSqr :: Point -> Int
+lengthSqr (Point { x = x, y = y }) = x * x + y * y
+
+lengthSqr' :: Point -> Int
+lengthSqr' (Point { x, y }) = y * y + x * x
+
+
+translateX, translateY :: Point -> Int -> Point
+translateX p d = p { x = x p + d }
+translateY p d = p { y = y p + d }
+
    -- cgit v1.2.3 From 395a9c3941f8b8891cffa5c17e1f6ae414edaa79 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 00:47:32 +0200 Subject: Make hyperlinker test runner strip local links from generated source. --- hypsrc-test/Utils.hs | 26 ++++++++++++++++++++++++++ hypsrc-test/run.hs | 37 +++++++++++++++++++++++++++---------- 2 files changed, 53 insertions(+), 10 deletions(-) create mode 100644 hypsrc-test/Utils.hs diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs new file mode 100644 index 00000000..cf3e94ea --- /dev/null +++ b/hypsrc-test/Utils.hs @@ -0,0 +1,26 @@ +module Utils + ( stripLocalAnchors + , stripLocalLinks + , stripLocalReferences + ) where + + +import Data.List + + +replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] +replaceBetween _ _ _ [] = [] +replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of + Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip + Nothing -> x:(replaceBetween' xs') + where + replaceBetween' = replaceBetween pref end val + +stripLocalAnchors :: String -> String +stripLocalAnchors = replaceBetween " String +stripLocalLinks = replaceBetween " String +stripLocalReferences = stripLocalLinks . stripLocalAnchors diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index e9a38c0c..5b6b6548 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -18,6 +18,8 @@ import System.Process import Distribution.Verbosity import Distribution.Simple.Utils hiding (die) +import Utils + baseDir, rootDir :: FilePath baseDir = takeDirectory __FILE__ @@ -64,14 +66,9 @@ check strict mdl = do hasReference <- doesFileExist refFile if hasReference then do - out <- readFile outFile ref <- readFile refFile - if out == ref - then putStrLn $ "Pass: " ++ mdl - else do - putStrLn $ "Fail: " ++ mdl - diff refFile outFile - when strict $ die "Aborting further tests." + out <- readFile outFile + compareOutput strict mdl ref out else do putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" where @@ -79,13 +76,33 @@ check strict mdl = do outFile = outDir' takeBaseName mdl ++ ".html" -diff :: FilePath -> FilePath -> IO () -diff fileA fileB = do +compareOutput :: Bool -> FilePath -> String -> String -> IO () +compareOutput strict mdl ref out = do + if ref' == out' + then putStrLn $ "Pass: " ++ mdl + else do + putStrLn $ "Fail: " ++ mdl + diff mdl ref' out' + when strict $ die "Aborting further tests." + where + ref' = stripLocalReferences ref + out' = stripLocalReferences out + + +diff :: FilePath -> String -> String -> IO () +diff mdl ref out = do colorDiffPath <- findProgramLocation silent "colordiff" let cmd = fromMaybe "diff" colorDiffPath - result <- system $ cmd ++ " " ++ fileA ++ " " ++ fileB + writeFile refFile ref + writeFile outFile out + + result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile unless (result == ExitSuccess) $ die "Failed to run `diff` command." + where + refFile = outDir takeFileName mdl ".ref.nolinks" + outFile = outDir takeFileName mdl ".nolinks" + getAllSrcModules :: IO [FilePath] -- cgit v1.2.3 From 767569881732c59378fb577d1a2b57b51bc454d0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 01:14:59 +0200 Subject: Create simple script for accepting hyperlinker test case references. --- haddock.cabal | 1 + hypsrc-test/Utils.hs | 27 ++++++++++++++++++++++++--- hypsrc-test/accept.hs | 27 +++++++++++++++++++++++++++ hypsrc-test/run.hs | 25 ++++--------------------- 4 files changed, 56 insertions(+), 24 deletions(-) create mode 100755 hypsrc-test/accept.hs diff --git a/haddock.cabal b/haddock.cabal index 01e6a558..2a1caee7 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -128,6 +128,7 @@ test-suite hypsrc-test main-is: run.hs hs-source-dirs: hypsrc-test build-depends: base, directory, process, filepath, Cabal + ghc-options: -Wall -fwarn-tabs test-suite latex-test type: exitcode-stdio-1.0 diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs index cf3e94ea..e15fabee 100644 --- a/hypsrc-test/Utils.hs +++ b/hypsrc-test/Utils.hs @@ -1,12 +1,33 @@ +{-# LANGUAGE CPP #-} + + module Utils - ( stripLocalAnchors - , stripLocalLinks - , stripLocalReferences + ( baseDir, rootDir + , srcDir, refDir, outDir, refDir', outDir' + , haddockPath + , stripLocalAnchors, stripLocalLinks, stripLocalReferences ) where import Data.List +import System.FilePath + + +baseDir, rootDir :: FilePath +baseDir = takeDirectory __FILE__ +rootDir = baseDir ".." + +srcDir, refDir, outDir, refDir', outDir' :: FilePath +srcDir = baseDir "src" +refDir = baseDir "ref" +outDir = baseDir "out" +refDir' = refDir "src" +outDir' = outDir "src" + +haddockPath :: FilePath +haddockPath = rootDir "dist" "build" "haddock" "haddock" + replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] replaceBetween _ _ _ [] = [] diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs new file mode 100755 index 00000000..4606b2df --- /dev/null +++ b/hypsrc-test/accept.hs @@ -0,0 +1,27 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE CPP #-} + + +import System.Directory +import System.FilePath +import System.Environment + +import Utils + + +main :: IO () +main = do + args <- getArgs + files <- filter isHtmlFile <$> getDirectoryContents outDir' + let files' = if args == ["--all"] || args == ["-a"] + then files + else filter ((`elem` args) . takeBaseName) files + mapM_ copy files' + where + isHtmlFile = (== ".html") . takeExtension + + +copy :: FilePath -> IO () +copy file = do + content <- stripLocalReferences <$> readFile (outDir' file) + writeFile (refDir' file) content diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 5b6b6548..10b6c257 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -2,13 +2,11 @@ {-# LANGUAGE CPP #-} -import Control.Applicative import Control.Monad import Data.List import Data.Maybe -import System.IO import System.Directory import System.Environment import System.Exit @@ -21,21 +19,6 @@ import Distribution.Simple.Utils hiding (die) import Utils -baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ -rootDir = baseDir ".." - -srcDir, refDir, outDir, refDir', outDir' :: FilePath -srcDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" -refDir' = refDir "src" -outDir' = outDir "src" - -haddockPath :: FilePath -haddockPath = rootDir "dist" "build" "haddock" "haddock" - - main :: IO () main = do haddockAvailable <- doesFileExist haddockPath @@ -107,9 +90,9 @@ diff mdl ref out = do getAllSrcModules :: IO [FilePath] getAllSrcModules = - filter isValid <$> getDirectoryContents srcDir + filter isHaskellFile <$> getDirectoryContents srcDir where - isValid = (== ".hs") . takeExtension + isHaskellFile = (== ".hs") . takeExtension putHaddockVersion :: IO () @@ -128,8 +111,8 @@ putGhcVersion = do runHaddock :: [String] -> IO () runHaddock args = do - env <- Just <$> getEnvironment - handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing + menv <- Just <$> getEnvironment + handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing waitForSuccess handle $ "Failed to invoke haddock with " ++ show args -- cgit v1.2.3 From db51ad0a5b2b29749f69fd82513adeedc8729735 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 01:16:41 +0200 Subject: Re-accept hyperlinker test cases with local references stripped out. --- hypsrc-test/ref/src/Constructors.html | 24 +++---- hypsrc-test/ref/src/Identifiers.html | 118 +++++++++++++++++----------------- hypsrc-test/ref/src/Literals.html | 10 +-- hypsrc-test/ref/src/Operators.html | 104 +++++++++++++++--------------- hypsrc-test/ref/src/Records.html | 64 +++++++++--------- 5 files changed, 160 insertions(+), 160 deletions(-) diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 713a85f0..6d6c7c06 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -315,16 +315,16 @@ > foo n* n foo, xs= xs, xsreverse xs x y= x+ x y x* y+ y x y= y+ x x y- x+ y x y= x* y* y* y* x x x x x x x y z| x x| y y| z z(-x(-y(-z x y z x y zNum a=> aFractional a=> a[[a [a [a [a a b= a++ b++ a [a [a [a a b= b a [a [a [a) a= a) a_:b= a (a b[[a [a [a a b b) a[[a[[a[[a a b [a b (a b x y= x= y= x= y= x* x+ y* y= y* y+ x* x p d= p p+ d p d= p p+ d Date: Wed, 1 Jul 2015 01:22:09 +0200 Subject: Fix bug with diffing wrong files in hyperlinker test runner. --- hypsrc-test/run.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs index 10b6c257..853c4f09 100755 --- a/hypsrc-test/run.hs +++ b/hypsrc-test/run.hs @@ -83,8 +83,8 @@ diff mdl ref out = do result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile unless (result == ExitSuccess) $ die "Failed to run `diff` command." where - refFile = outDir takeFileName mdl ".ref.nolinks" - outFile = outDir takeFileName mdl ".nolinks" + refFile = outDir takeBaseName mdl ++ ".ref.nolinks" + outFile = outDir takeBaseName mdl ++ ".nolinks" -- cgit v1.2.3 From 4b0b4a834b7eeeb0c688ab8718bc9720c00ee67c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 18:04:46 +0200 Subject: Remove unused dependencies in Haddock API spec configuration. --- haddock-api/haddock-api.cabal | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 56889e66..11567f99 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -111,18 +111,7 @@ test-suite spec build-depends: base >= 4.3 && < 4.9 - , bytestring - , filepath - , directory , containers - , deepseq - , array - , xhtml >= 3000.2 && < 3000.3 - , Cabal >= 1.10 - , ghc >= 7.10 && < 7.10.2 - - , ghc-paths - , haddock-library == 1.2.* , hspec , QuickCheck == 2.* -- cgit v1.2.3 From b91ee2f4f0869d1c1076813019ce858c53738042 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 18:32:19 +0200 Subject: Add support for hyperlinking synonyms in patterns. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c41b5e5f..8777e26d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -110,6 +110,8 @@ binds = pure (sspan, RtkBind name) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs + (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) _ -> empty rec term = case cast term of (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> -- cgit v1.2.3 From dc2eed5daa4d01f97a4686352fd17405f4567169 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 18:33:44 +0200 Subject: Create test case for hyperlinking @-patterns. --- hypsrc-test/ref/src/Constructors.html | 298 ++++++++++++++++++++++++++++++++++ hypsrc-test/src/Constructors.hs | 8 + 2 files changed, 306 insertions(+) diff --git a/hypsrc-test/ref/src/Constructors.html b/hypsrc-test/ref/src/Constructors.html index 6d6c7c06..96be3627 100644 --- a/hypsrc-test/ref/src/Constructors.html +++ b/hypsrc-test/ref/src/Constructors.html @@ -529,6 +529,304 @@ >undefined + + +unnorf' :: Norf -> Int +unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) = + x' + n * unfoo f1 + aux f3 + where + aux fx = unfoo f2 * unfoo fx * unfoo f3 + x' = sum . map unfoo . unnorf $ x [Foo] unnorf (Norf (Bar, xs, Bar)) = xs unnorf (Norf (Baz, xs, Baz)) = reverse xs unnorf _ = undefined + + +unnorf' :: Norf -> Int +unnorf' x@(Norf (f1@(Quux _ n), _, f2@(Quux f3 _))) = + x' + n * unfoo f1 + aux f3 + where + aux fx = unfoo f2 * unfoo fx * unfoo f3 + x' = sum . map unfoo . unnorf $ x -- cgit v1.2.3 From dd781d18eca0d8c28350093d78926d4a9b474827 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:06:04 +0200 Subject: Add support for hyperlinking universally quantified type variables. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 8777e26d..79e31db7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -99,7 +99,7 @@ types = -- clauses). binds :: GHC.RenamedSource -> DetailsMap binds = - everything (<|>) (fun `combine` pat) + everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> @@ -117,6 +117,12 @@ binds = (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> pure (sspan, RtkVar name) _ -> empty + tvar term = case cast term of + (Just (GHC.L sspan (GHC.UserTyVar name))) -> + pure (sspan, RtkBind name) + (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) + _ -> empty -- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap -- cgit v1.2.3 From 571944f4a81feae7e04b05d1549a19e0b677f4eb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:28:32 +0200 Subject: Create hyperlinker test case with quantified type variables. --- hypsrc-test/src/Polymorphism.hs | 55 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 hypsrc-test/src/Polymorphism.hs diff --git a/hypsrc-test/src/Polymorphism.hs b/hypsrc-test/src/Polymorphism.hs new file mode 100644 index 00000000..2e1a93bd --- /dev/null +++ b/hypsrc-test/src/Polymorphism.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE RankNTypes #-} + + +module Polymorphism where + + +foo :: a -> a -> a +foo = undefined + +foo' :: forall a. a -> a -> a +foo' = undefined + +bar :: a -> b -> (a, b) +bar = undefined + +bar' :: forall a b. a -> b -> (a, b) +bar' = undefined + +baz :: a -> (a -> [a -> a] -> b) -> b +baz = undefined + +baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b +baz' = undefined + +quux :: a -> (forall a. a -> a) -> a +quux = undefined + +quux' :: forall a. a -> (forall a. a -> a) -> a +quux' = undefined + + +num :: Num a => a -> a -> a +num = undefined + +num' :: forall a. Num a => a -> a -> a +num' = undefined + +eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq = undefined + +eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) +eq' = undefined + +mon :: Monad m => (a -> m a) -> m a +mon = undefined + +mon' :: forall m a. Monad m => (a -> m a) -> m a +mon' = undefined + + +norf :: a -> (forall a. Ord a => a -> a) -> a +norf = undefined + +norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a +norf' = undefined -- cgit v1.2.3 From 2b748bb10a40d3787bea35fc24564edac64b11c9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:34:22 +0200 Subject: Add scoped type variables test for polymorphism test case. --- hypsrc-test/src/Polymorphism.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/hypsrc-test/src/Polymorphism.hs b/hypsrc-test/src/Polymorphism.hs index 2e1a93bd..a74ac492 100644 --- a/hypsrc-test/src/Polymorphism.hs +++ b/hypsrc-test/src/Polymorphism.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Polymorphism where @@ -53,3 +54,13 @@ norf = undefined norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a norf' = undefined + + +plugh :: forall a. a -> a +plugh x = x :: a + +thud :: forall a b. (a -> b) -> a -> (a, b) +thud f x = + (x :: a, y) :: (a, b) + where + y = (f :: a -> b) x :: b -- cgit v1.2.3 From d6fcd4692c1d77003ed83c9faf22a2d922dd761f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:56:27 +0200 Subject: Add record wildcards test for records hyperlinking test case. --- hypsrc-test/ref/src/Records.html | 241 +++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Records.hs | 9 ++ 2 files changed, 250 insertions(+) diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index cdff7eb5..0751782a 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -11,6 +11,12 @@ >{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + } + +translate :: Int -> Int -> Point -> Point +translate x y p = + aux p + where + (dx, dy) = (x, y) + aux Point{..} = p { x = x + dx, y = y + dy } Int -> Point translateX p d = p { x = x p + d } translateY p d = p { y = y p + d } + +translate :: Int -> Int -> Point -> Point +translate x y p = + aux p + where + (dx, dy) = (x, y) + aux Point{..} = p { x = x + dx, y = y + dy } -- cgit v1.2.3 From 980664b29a588eef44d8048d4beedce4d2a96b09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 21:01:42 +0200 Subject: Document some functions in XHTML utlity module. --- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 36ecf863..5166549a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -41,11 +41,19 @@ import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) +-- | Replace placeholder string elements with provided values. +-- +-- Used to generate URL for customized external paths, usually provided with +-- @--source-module@, @--source-entity@ and related command-line arguments. +-- +-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}" +-- "output/Foo.hs#foo" spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) +-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'. spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run -- cgit v1.2.3 From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 22:25:21 +0200 Subject: Make hyperlinker render qualified names as one entity. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 50 +++++++++++++++++++--- 2 files changed, 46 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 79e31db7..decb1206 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -25,6 +25,7 @@ data TokenDetails | RtkBind GHC.Name | RtkDecl GHC.Name | RtkModule GHC.ModuleName + deriving (Eq) rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName rtkName (RtkVar name) = Left name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 89d9b60d..ddb2e5b9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -19,15 +19,46 @@ import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html + type StyleClass = String + render :: Maybe FilePath -> Maybe FilePath -> GHC.PackageKey -> SrcMap -> [RichToken] -> Html render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens + +data TokenGroup + = GrpNormal Token + | GrpRich TokenDetails [Token] + + +-- | Group consecutive tokens pointing to the same element. +-- +-- We want to render qualified identifiers as one entity. For example, +-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for +-- better user experience when highlighting and clicking links, these tokens +-- should be regarded as one identifier. Therefore, before rendering we must +-- group consecutive elements pointing to the same 'GHC.Name' (note that even +-- dot token has it if it is part of qualified name). +groupTokens :: [RichToken] -> [TokenGroup] +groupTokens [] = [] +groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) +groupTokens ((RichToken tok (Just det)):rest) = + let (grp, rest') = span same rest + in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') + where + same (RichToken _ (Just det')) = det == det' + same _ = False + + body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) +body pkg srcs tokens = + Html.body . Html.pre $ hypsrc + where + hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -47,20 +78,29 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html -richToken _ _ (RichToken tok Nothing) = + +tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html +tokenGroup _ _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken pkg srcs (RichToken tok (Just det)) = +tokenGroup pkg srcs (GrpRich det tokens) = externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where - content = tokenSpan tok ! [ multiclass style] + content = mconcat . map (richToken det) $ tokens + + +richToken :: TokenDetails -> Token -> Html +richToken det tok = + tokenSpan tok ! [ multiclass style ] + where style = (tokenStyle . tkType) tok ++ richTokenStyle det + tokenSpan :: Token -> Html tokenSpan = Html.thespan . Html.toHtml . tkValue + richTokenStyle :: TokenDetails -> [StyleClass] richTokenStyle (RtkVar _) = ["hs-var"] richTokenStyle (RtkType _) = ["hs-type"] -- cgit v1.2.3 From 8071c27826d60eec1cb20f00f9767c32366defac Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 22:27:38 +0200 Subject: Add qualified name test for identifiers hyperlinking test case. --- hypsrc-test/ref/src/Identifiers.html | 45 ++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Identifiers.hs | 1 + 2 files changed, 46 insertions(+) diff --git a/hypsrc-test/ref/src/Identifiers.html b/hypsrc-test/ref/src/Identifiers.html index 4c82ad01..14cfbd8b 100644 --- a/hypsrc-test/ref/src/Identifiers.html +++ b/hypsrc-test/ref/src/Identifiers.html @@ -737,6 +737,51 @@ > + putStrLn . show $ Identifiers.norf x y z where Date: Thu, 2 Jul 2015 12:32:59 +0200 Subject: Fix crash happening when hyperlinking type family declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index decb1206..c12ac35a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -135,6 +135,7 @@ decls (group, _, _, _) = concatMap ($ group) typ (GHC.L _ t) = case t of GHC.DataDecl name _ defn _ -> [decl name] ++ concatMap con (GHC.dd_cons defn) + GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -- cgit v1.2.3 From 5c01af0e605c2bd16382cbd0de7102f1fbc2f361 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 12:47:03 +0200 Subject: Add support for anchoring data family constructor declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c12ac35a..b592326d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -129,20 +129,21 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) fun + , everything (<|>) (fun `combine` con) ] where typ (GHC.L _ t) = case t of - GHC.DataDecl name _ defn _ -> - [decl name] ++ concatMap con (GHC.dd_cons defn) + GHC.DataDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty - con (GHC.L _ t) = - map decl (GHC.con_names t) ++ everything (<|>) fld t + con term = case cast term of + (Just cdcl) -> + map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl + Nothing -> empty fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty -- cgit v1.2.3 From 28e93ceec440d0d1ed053bbf3c20e4bdcd6d5f4e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:31:05 +0200 Subject: Improve support for hyperlinking type families. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index b592326d..4b60ca37 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -129,7 +129,7 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) (fun `combine` con) + , everything (<|>) (fun `combine` con `combine` ins) ] where typ (GHC.L _ t) = case t of @@ -144,10 +144,16 @@ decls (group, _, _, _) = concatMap ($ group) (Just cdcl) -> map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl Nothing -> empty + ins term = case cast term of + (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> + pure . tyref $ GHC.tfe_tycon eqn + _ -> empty fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty decl (GHC.L sspan name) = (sspan, RtkDecl name) + tyref (GHC.L sspan name) = (sspan, RtkType name) -- | Obtain details map for import declarations. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 019075a1..37cc5377 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -197,6 +197,7 @@ keywords = , "type" , "where" , "forall" + , "family" , "mdo" ] -- cgit v1.2.3 From 0ea2c4a892346d4fdd38c50cf234dbc5e23ac299 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:33:34 +0200 Subject: Add hyperlinker test case for checking type and type family declarations. --- hypsrc-test/ref/src/Types.html | 937 +++++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Types.hs | 42 ++ 2 files changed, 979 insertions(+) create mode 100644 hypsrc-test/ref/src/Types.html create mode 100644 hypsrc-test/src/Types.hs diff --git a/hypsrc-test/ref/src/Types.html b/hypsrc-test/ref/src/Types.html new file mode 100644 index 00000000..bdb68ed6 --- /dev/null +++ b/hypsrc-test/ref/src/Types.html @@ -0,0 +1,937 @@ + +
    {-# LANGUAGE TypeFamilies #-}
+
+
+module Types where
+
+
+data Quux = Bar | Baz
+
+newtype Foo = Foo ()
+
+type FooQuux = (Foo, Quux)
+type QuuxFoo = (Quux, Foo)
+
+
+data family Norf a b
+
+data instance Norf Foo Quux = NFQ Foo Quux
+data instance Norf Quux Foo = NQF Quux Foo
+
+
+type family Norf' a b
+
+type instance Norf' Foo Quux = (Foo, Quux)
+type instance Norf' Quux Foo = (Quux, Foo)
+
+
+norf1 :: Norf Foo Quux -> Int
+norf1 (NFQ (Foo ()) Bar) = 0
+norf1 (NFQ (Foo ()) Baz) = 1
+
+norf2 :: Norf Quux Foo -> Int
+norf2 (NQF Bar (Foo ())) = 0
+norf2 (NQF Baz (Foo ())) = 1
+
+
+norf1' :: Norf' Foo Quux -> Int
+norf1' (Foo (), Bar) = 0
+norf1' (Foo (), Baz) = 1
+
+norf2' :: Norf' Quux Foo -> Int
+norf2' (Bar, Foo ()) = 0
+norf2' (Baz, Foo ()) = 1
+
    diff --git a/hypsrc-test/src/Types.hs b/hypsrc-test/src/Types.hs new file mode 100644 index 00000000..b63a825b --- /dev/null +++ b/hypsrc-test/src/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeFamilies #-} + + +module Types where + + +data Quux = Bar | Baz + +newtype Foo = Foo () + +type FooQuux = (Foo, Quux) +type QuuxFoo = (Quux, Foo) + + +data family Norf a b + +data instance Norf Foo Quux = NFQ Foo Quux +data instance Norf Quux Foo = NQF Quux Foo + + +type family Norf' a b + +type instance Norf' Foo Quux = (Foo, Quux) +type instance Norf' Quux Foo = (Quux, Foo) + + +norf1 :: Norf Foo Quux -> Int +norf1 (NFQ (Foo ()) Bar) = 0 +norf1 (NFQ (Foo ()) Baz) = 1 + +norf2 :: Norf Quux Foo -> Int +norf2 (NQF Bar (Foo ())) = 0 +norf2 (NQF Baz (Foo ())) = 1 + + +norf1' :: Norf' Foo Quux -> Int +norf1' (Foo (), Bar) = 0 +norf1' (Foo (), Baz) = 1 + +norf2' :: Norf' Quux Foo -> Int +norf2' (Bar, Foo ()) = 0 +norf2' (Baz, Foo ()) = 1 -- cgit v1.2.3 From aa6c6deba47af1c21765ed09dc0317825aa1d78d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:41:38 +0200 Subject: Fix issue with operators being recognized as preprocessor directives. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++--- hypsrc-test/src/Operators.hs | 4 ++++ 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 37cc5377..d927aa08 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -156,17 +156,17 @@ classify str | "--" `isPrefixOf` str = TkComment | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment -classify (c:_) +classify str@(c:_) | isSpace c = TkSpace | isDigit c = TkNumber | c `elem` special = TkSpecial + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator | c == '#' = TkCpp | c == '"' = TkString | c == '\'' = TkChar classify str | str `elem` keywords = TkKeyword - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator | isIdentifier str = TkIdentifier | otherwise = TkUnknown diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs index bc76c2d3..8e86ab0b 100644 --- a/hypsrc-test/src/Operators.hs +++ b/hypsrc-test/src/Operators.hs @@ -16,3 +16,7 @@ a */\* b = concatMap (*** b) a (**/\**) :: [[a]] -> [[a]] -> [[a]] a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) + + +(#.#) :: a -> b -> (c -> (a, b)) +a #.# b = const $ (a, b) -- cgit v1.2.3 From 257e0456854a0835bb9901b6d73c17f6f8d0d841 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 17:18:12 +0200 Subject: Fix broken tests for parsing and hyperlinking hash operators. --- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 2 +- hypsrc-test/ref/src/Operators.html | 122 +++++++++++++++++++++ 2 files changed, 123 insertions(+), 1 deletion(-) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 38cdbc87..a76bdcdc 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -52,7 +52,7 @@ parseSpec = do it "should recognize preprocessor directives" $ do "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] "x # y" `shouldParseTo` - [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier] + [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] it "should distinguish basic language constructs" $ do "(* 2) <$> (\"abc\", foo)" `shouldParseTo` diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html index 9ed24ab9..beefda58 100644 --- a/hypsrc-test/ref/src/Operators.html +++ b/hypsrc-test/ref/src/Operators.html @@ -648,6 +648,128 @@ >) + + +(#.#) :: a -> b -> (c -> (a, b)) +a #.# b = const $ (a, b) Date: Thu, 2 Jul 2015 18:53:28 +0200 Subject: Add support for anchoring signatures in type class declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 4b60ca37..98c9770f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + module Haddock.Backends.Hyperlinker.Ast ( enrich @@ -135,6 +137,7 @@ decls (group, _, _, _) = concatMap ($ group) typ (GHC.L _ t) = case t of GHC.DataDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) @@ -152,6 +155,8 @@ decls (group, _, _, _) = concatMap ($ group) fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty + sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names + sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) -- cgit v1.2.3 From ef3b8691ea607bd4f67d5dc77bb226cf57ec4c30 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 19:04:47 +0200 Subject: Make hyperlinker generate anchors only to top-level value bindings. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 98c9770f..1e121c2e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -131,7 +131,8 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) (fun `combine` con `combine` ins) + , everything (<|>) fun . GHC.hs_valds + , everything (<|>) (con `combine` ins) ] where typ (GHC.L _ t) = case t of -- cgit v1.2.3 From 29bb1ce86e12b368c4eb91dbf515391a0958b8c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 19:05:58 +0200 Subject: Create hyperlinker test case for type classes. --- hypsrc-test/ref/src/Classes.html | 931 +++++++++++++++++++++++++++++++++++++++ hypsrc-test/src/Classes.hs | 38 ++ 2 files changed, 969 insertions(+) create mode 100644 hypsrc-test/ref/src/Classes.html create mode 100644 hypsrc-test/src/Classes.hs diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html new file mode 100644 index 00000000..a5a3d243 --- /dev/null +++ b/hypsrc-test/ref/src/Classes.html @@ -0,0 +1,931 @@ + +
    module Classes where
+
+
+class Foo a where
+    bar :: a -> Int
+    baz :: Int -> (a, a)
+
+instance Foo Int where
+    bar = id
+    baz x = (x, x)
+
+instance Foo [a] where
+    bar = length
+    baz _ = ([], [])
+
+
+class Foo a => Foo' a where
+    quux :: (a, a) -> a
+    quux (x, y) = norf [x, y] 
+
+    norf :: [a] -> a
+    norf = quux . baz . sum . map bar
+
+instance Foo' Int where
+    norf = sum
+
+instance Foo' [a] where
+    quux = uncurry (++)
+
+
+class Plugh p where
+    plugh :: p a a -> p b b -> p (a -> b) (b -> a)
+
+instance Plugh Either where
+    plugh (Left a) _ = Right $ const a
+    plugh (Right a) _ = Right $ const a
+    plugh _ (Left b) = Left $ const b
+    plugh _ (Right b) = Left $ const b
+
    diff --git a/hypsrc-test/src/Classes.hs b/hypsrc-test/src/Classes.hs new file mode 100644 index 00000000..bddb9939 --- /dev/null +++ b/hypsrc-test/src/Classes.hs @@ -0,0 +1,38 @@ +module Classes where + + +class Foo a where + bar :: a -> Int + baz :: Int -> (a, a) + +instance Foo Int where + bar = id + baz x = (x, x) + +instance Foo [a] where + bar = length + baz _ = ([], []) + + +class Foo a => Foo' a where + quux :: (a, a) -> a + quux (x, y) = norf [x, y] + + norf :: [a] -> a + norf = quux . baz . sum . map bar + +instance Foo' Int where + norf = sum + +instance Foo' [a] where + quux = uncurry (++) + + +class Plugh p where + plugh :: p a a -> p b b -> p (a -> b) (b -> a) + +instance Plugh Either where + plugh (Left a) _ = Right $ const a + plugh (Right a) _ = Right $ const a + plugh _ (Left b) = Left $ const b + plugh _ (Right b) = Left $ const b -- cgit v1.2.3 From 9c156cdcfd7d042ed9cfa242871846291af5cf0a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 16:28:26 +0200 Subject: Update docs with information about source hyperlinking. --- doc/haddock.xml | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/doc/haddock.xml b/doc/haddock.xml index b528fdb5..6c83f618 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -528,6 +528,43 @@ $ pdflatex package.tex + + + + + + + Generate hyperlinked source code (as HTML web page). All + rendered files will be put into + src/ subfolder of output + directory. + Usually, this should be used in combination with + option - generated documentation will then + contain references to appropriate code fragments. Previously, this + behaviour could be achieved by generating sources using external + tool and specifying , + , + and related options. Note that these flags are ignored once + is set. + In order to make cross-package source hyperlinking possible, + appropriate source paths have to be set up when providing + interface files using + option. + + + + + + + + + + Use custom CSS file for sources rendered by the + option. If no custom style + file is provided, Haddock will use default one. + + + -- cgit v1.2.3 From 820381b78d1f0f7487e120c22913629863a8d1eb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 16:52:15 +0200 Subject: Update docs on using `--read-interface` option. --- doc/haddock.xml | 36 +++++++++++++++++++++++++++++------- 1 file changed, 29 insertions(+), 7 deletions(-) diff --git a/doc/haddock.xml b/doc/haddock.xml index 6c83f618..b28006f6 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -345,11 +345,27 @@ - path,file + file + + + + docpath,file + + + + docpath,srcpath,file + + + + =file - =path,file + =docpath,file + + + + =docpath,srcpath,file Read the interface file in @@ -357,19 +373,25 @@ produced by running Haddock with the option. The interface describes a set of modules whose HTML documentation is - located in path (which may be a - relative pathname). The path is - optional, and defaults to .. + located in docpath (which may be a + relative pathname). The docpath is + optional, and defaults to .. The + srcpath is optional but has no default + value. This option allows Haddock to produce separate sets of documentation with hyperlinks between them. The - path is used to direct hyperlinks + docpath is used to direct hyperlinks to point to the right files; so make sure you don't move the HTML files later or these links will break. Using a - relative path means that a + relative docpath means that a documentation subtree can still be moved around without breaking links. + Similarly to docpath, srcpath is used generate cross-package hyperlinks but + within sources rendered with + option. + Multiple options may be given. -- cgit v1.2.3 From a86147030e0f8fe33ebd4b358ac04d3beb45c3f8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 17:15:26 +0200 Subject: Remove potentially dangerous record access in hyperlinker AST module. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 1e121c2e..9d5c127d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -137,9 +137,9 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl name _ _ _ -> pure . decl $ name + GHC.SynDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs - _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) -- cgit v1.2.3 From cab1191dfb7738c020a1eef9e9d4efe6c4f27a51 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 17:40:10 +0200 Subject: Make Haddock generate warnings about potential misuse of hyperlinker. --- haddock-api/src/Haddock.hs | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 02e19531..5a1c6abe 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -159,6 +159,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do _ -> return flags unless (Flag_NoWarnings `elem` flags) $ do + hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning @@ -491,6 +492,35 @@ shortcutFlags flags = do ++ "Ported to use the GHC API by David Waern 2006-2008\n" +-- | Generate some warnings about potential misuse of @--hyperlinked-source@. +hypSrcWarnings :: [Flag] -> IO () +hypSrcWarnings flags = do + + when (hypSrc && any isSourceUrlFlag flags) $ + hPutStrLn stderr $ concat + [ "Warning: " + , "--source-* options are ignored when " + , "--hyperlinked-source is enabled." + ] + + when (not hypSrc && any isSourceCssFlag flags) $ + hPutStrLn stderr $ concat + [ "Warning: " + , "source CSS file is specified but " + , "--hyperlinked-source is disabled." + ] + + where + hypSrc = Flag_HyperlinkedSource `elem` flags + isSourceUrlFlag (Flag_SourceBaseURL _) = True + isSourceUrlFlag (Flag_SourceModuleURL _) = True + isSourceUrlFlag (Flag_SourceEntityURL _) = True + isSourceUrlFlag (Flag_SourceLEntityURL _) = True + isSourceUrlFlag _ = False + isSourceCssFlag (Flag_SourceCss _) = True + isSourceCssFlag _ = False + + updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) -- cgit v1.2.3 From 861c45b6c16e76e901553739bdb7d7c7e2f827f0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 17:43:22 +0200 Subject: Fix incorrect specification of source style option in doc file. --- doc/haddock.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/haddock.xml b/doc/haddock.xml index b28006f6..e2845212 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -577,8 +577,8 @@ $ pdflatex package.tex - - + + Use custom CSS file for sources rendered by the -- cgit v1.2.3 From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 5 Jul 2015 17:06:36 +0200 Subject: Refactor source path mapping to use modules as indices. --- haddock-api/src/Haddock.hs | 27 ++++++++++------ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 15 ++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 36 ++++++++++------------ haddock-api/src/Haddock/InterfaceFile.hs | 11 ++++--- haddock-api/src/Haddock/Types.hs | 9 +++++- 5 files changed, 55 insertions(+), 43 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5a1c6abe..5c48d28b 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -46,6 +46,7 @@ import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef +import Data.Map (Map) import qualified Data.Map as Map import System.IO import System.Exit @@ -228,13 +229,14 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap + extSrcMap = Map.fromList + [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ] + render dflags flags qual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap' + srcMap = Map.union + (Map.map SrcExternal extSrcMap) + (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) + + pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap + pkgSrcMap' | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap - | otherwise = srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') + sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 1fadef49..f007f970 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) -import GHC import Data.Maybe import System.Directory @@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> PackageKey -- ^ Package for which we create source - -> SrcMap -- ^ Paths to external sources + -> SrcMap -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool - -> PackageKey -> SrcMap -> Interface +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where - render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + render' = render (Just srcCssFile) (Just highlightScript) srcs html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index ddb2e5b9..a4d7bc2d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -23,10 +23,9 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath - -> GHC.PackageKey -> SrcMap -> [RichToken] +render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] -> Html -render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens +render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens data TokenGroup @@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) = same _ = False -body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs tokens = +body :: SrcMap -> [RichToken] -> Html +body srcs tokens = Html.body . Html.pre $ hypsrc where - hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens header :: Maybe FilePath -> Maybe FilePath -> Html @@ -79,13 +78,13 @@ header mcss mjs = ] -tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html -tokenGroup _ _ (GrpNormal tok) = +tokenGroup :: SrcMap -> TokenGroup -> Html +tokenGroup _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -tokenGroup pkg srcs (GrpRich det tokens) = - externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content +tokenGroup srcs (GrpRich det tokens) = + externalAnchor det . internalAnchor det . hyperlink srcs det $ content where content = mconcat . map (richToken det) $ tokens @@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html -hyperlink pkg srcs details = case rtkName details of +hyperlink :: SrcMap -> TokenDetails -> Html -> Html +hyperlink srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink pkg srcs name + else externalNameHyperlink srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink pkg srcs name content - | namePkg == pkg = Html.anchor content ! +externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink srcs name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] - | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleNameUrl mdl name ] - | otherwise = content + Nothing -> content where mdl = GHC.nameModule name - namePkg = GHC.modulePackageKey mdl -- TODO: Implement module hyperlinks. -- diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 4b39d315..d5762ce8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifModule, ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifModule :: InterfaceFile -> Module +ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> instMod iface + +ifPackageKey :: InterfaceFile -> PackageKey +ifPackageKey = modulePackageKey . ifModule binaryInterfaceMagic :: Word32 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index fbb5f44c..da4b3eec 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -50,7 +50,7 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath +type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal -- | Extends 'Name' with cross-reference information. data DocName -- cgit v1.2.3 From 5927bfd4737532e7f1282672a96c2a2cb83c847f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 5 Jul 2015 17:47:34 +0200 Subject: Fix bug where not all module interfaces were added to source mapping. --- haddock-api/src/Haddock.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5c48d28b..d4d8e3e6 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -229,8 +229,10 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - extSrcMap = Map.fromList - [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ] + extSrcMap = Map.fromList $ do + ((_, Just path), ifile) <- pkgs + iface <- ifInstalledIfaces ifile + return (instMod iface, path) render dflags flags qual interfaces installedIfaces extSrcMap -- cgit v1.2.3 From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:39:57 +0200 Subject: Extract main hyperlinker types to separate module. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Ast.hs | 27 ++-------- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 40 ++------------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Types.hs | 59 ++++++++++++++++++++++ .../src/Haddock/Backends/Hyperlinker/Utils.hs | 1 + haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Types.hs | 3 +- haddock.cabal | 5 ++ 10 files changed, 79 insertions(+), 63 deletions(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 11567f99..3838c3d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f007f970..4b58190c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker , module Haddock.Backends.Hyperlinker.Utils ) where + import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 9d5c127d..28fdc3f5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,12 +3,10 @@ {-# LANGUAGE RecordWildCards #-} -module Haddock.Backends.Hyperlinker.Ast - ( enrich - , RichToken(..), TokenDetails(..), rtkName - ) where +module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Backends.Hyperlinker.Parser + +import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,25 +14,6 @@ import Control.Applicative import Data.Data import Data.Maybe -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d927aa08..e206413e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,44 +1,12 @@ -module Haddock.Backends.Hyperlinker.Parser - ( parse - , Token(..), TokenType(..) - , Position(..), Span(..) - ) where +module Haddock.Backends.Hyperlinker.Parser (parse) where + import Data.Char import Data.List import Data.Maybe -data Token = Token - { tkType :: TokenType - , tkValue :: String - , tkSpan :: Span - } - -data Position = Position - { posRow :: !Int - , posCol :: !Int - } - -data Span = Span - { spStart :: Position - , spEnd :: Position - } - -data TokenType - = TkIdentifier - | TkKeyword - | TkString - | TkChar - | TkNumber - | TkOperator - | TkGlyph - | TkSpecial - | TkSpace - | TkComment - | TkCpp - | TkPragma - | TkUnknown - deriving (Show, Eq) +import Haddock.Backends.Hyperlinker.Types + -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index a4d7bc2d..add1465b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,8 +1,8 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where + import Haddock.Types -import Haddock.Backends.Hyperlinker.Parser -import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import qualified GHC diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..19cc5288 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,59 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 9ba8446d..db2bfc76 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where + import Haddock.Backends.Xhtml.Utils import GHC diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59f7076f..0599151e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,7 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index da4b3eec..90dbb4d4 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable import Control.Monad (ap) -import Haddock.Backends.Hyperlinker.Ast + +import Haddock.Backends.Hyperlinker.Types ----------------------------------------------------------------------------- -- * Convenient synonyms diff --git a/haddock.cabal b/haddock.cabal index 2a1caee7..8fa9f33d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,6 +104,11 @@ executable haddock Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:52:13 +0200 Subject: Move source paths types to hyperlinker types module. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 13 +++++++++++++ haddock-api/src/Haddock/Types.hs | 9 --------- 4 files changed, 15 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 4b58190c..248a8a54 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,11 +1,13 @@ module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types , module Haddock.Backends.Hyperlinker.Utils ) where import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index add1465b..1065897d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,7 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where -import Haddock.Types import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index 19cc5288..ecb51a07 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC +import Data.Map (Map) + data Token = Token { tkType :: TokenType @@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name + + +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal + +type SrcMap = Map GHC.Module SrcPath diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 90dbb4d4..6dd64506 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -51,7 +51,6 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -272,14 +271,6 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module --- | Path for making cross-package hyperlinks in generated sources. --- --- Used in 'SrcMap' to determine whether module originates in current package --- or in an external package. -data SrcPath - = SrcExternal FilePath - | SrcLocal - -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module -- cgit v1.2.3 From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 17:06:19 +0200 Subject: Add support for hyperlinking modules in import lists. --- haddock-api/src/Haddock.hs | 2 +- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 21 +++++++++------------ .../src/Haddock/Backends/Hyperlinker/Types.hs | 10 +++++++--- 3 files changed, 17 insertions(+), 16 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d4d8e3e6..350a73ea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = Map.union + srcMap = mkSrcMap $ Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 1065897d..5037421a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of if GHC.isInternalName name then internalHyperlink name else externalNameHyperlink srcs name - Right name -> externalModHyperlink name + Right name -> externalModHyperlink srcs name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink srcs name content = case Map.lookup mdl srcs of +externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] Just (SrcExternal path) -> Html.anchor content ! @@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of where mdl = GHC.nameModule name --- TODO: Implement module hyperlinks. --- --- Unfortunately, 'ModuleName' is not enough to provide viable cross-package --- hyperlink. And the problem is that GHC AST does not have other information --- on imported modules, so for the time being, we do not provide such reference --- either. -externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ content = - content - --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html +externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path hypSrcModuleUrl' name ] + Nothing -> content diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index ecb51a07..c3954dc9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC import Data.Map (Map) +import qualified Data.Map as Map data Token = Token @@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name -- Used in 'SrcMap' to determine whether module originates in current package -- or in an external package. data SrcPath - = SrcExternal FilePath - | SrcLocal + = SrcExternal FilePath + | SrcLocal -type SrcMap = Map GHC.Module SrcPath +type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) + +mkSrcMap :: Map GHC.Module SrcPath -> SrcMap +mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) -- cgit v1.2.3 From b6e9968643bc0ab6c61289ecee7205e4d7bc421a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 17:26:49 +0200 Subject: Add short documentation for hyperlinker source map type. --- haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index c3954dc9..5f4dbc8c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -70,6 +70,15 @@ data SrcPath = SrcExternal FilePath | SrcLocal +-- | Mapping from modules to cross-package source paths. +-- +-- This mapping is actually a pair of maps instead of just one map. The reason +-- for this is because when hyperlinking modules in import lists we have no +-- 'GHC.Module' available. On the other hand, we can't just use map with +-- 'GHC.ModuleName' as indices because certain modules may have common name +-- but originate in different packages. Hence, we use both /rich/ and /poor/ +-- versions, where the /poor/ is just projection of /rich/ one cached in pair +-- for better performance. type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) mkSrcMap :: Map GHC.Module SrcPath -> SrcMap -- cgit v1.2.3 From 0e1cad7c38ed1a771794d9332233f784a52d2c1a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 18:07:20 +0200 Subject: Fix bug with module name being hyperlinked to `Prelude`. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++--- haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 1 + 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 28fdc3f5..71b73663 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -146,7 +146,7 @@ decls (group, _, _, _) = concatMap ($ group) -- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = - everything (<|>) ie src ++ map (imp . GHC.unLoc) imps + everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var v @@ -156,9 +156,10 @@ imports src@(_, imps, _, _) = _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl = + imp idecl | not . GHC.ideclImplicit $ idecl = let (GHC.L sspan name) = GHC.ideclName idecl - in (sspan, RtkModule name) + in Just (sspan, RtkModule name) + imp _ = Nothing -- | Check whether token stream span matches GHC source span. -- diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index a76bdcdc..8cd2690e 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -5,6 +5,7 @@ import Test.Hspec import Test.QuickCheck import Haddock.Backends.Hyperlinker.Parser +import Haddock.Backends.Hyperlinker.Types main :: IO () -- cgit v1.2.3 From d76c57b3bfade1916b83c11bdb81601990138dff Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 18:23:47 +0200 Subject: Fix problem with spec build in Haddock API configuration. --- haddock-api/haddock-api.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 3838c3d8..439c058c 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -113,6 +113,7 @@ test-suite spec build-depends: base >= 4.3 && < 4.9 , containers + , ghc >= 7.10 && < 7.10.2 , hspec , QuickCheck == 2.* -- cgit v1.2.3 From 53c47c6fc6cdaa5084b36ea6ba8320a460fa7106 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Fri, 3 Jul 2015 15:57:06 +0200 Subject: StrictData: print correct strictness marks --- haddock-api/src/Haddock/Backends/LaTeX.hs | 7 +++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e1090a0e..86a6909b 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -823,8 +823,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ (Just True)) = char '!' +ppBang (HsSrcBang _ _ (Just False)) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c0be9735..2da4cc1c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,9 +769,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" +ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d841aecc..c11ca545 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -269,13 +269,13 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) True - HsStrict -> HsSrcBang Nothing (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) + HsStrict -> HsSrcBang Nothing (Just False) (Just True) + HsLazy -> HsSrcBang Nothing Nothing Nothing _ -> bang in case src_bang of - HsNoBang -> tySyn + (HsSrcBang _ Nothing Nothing) -> tySyn _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. ) arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField -- cgit v1.2.3 From ad3b36b11ae2be54a1be4279cec659f09c5d00bf Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 7 Jul 2015 23:58:28 +0100 Subject: Update changelog --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index cb17fde7..ff49b6f5 100644 --- a/CHANGES +++ b/CHANGES @@ -21,6 +21,8 @@ Changes in version 2.16.1 * Fix alignment of Source link for instances in Firefox (#384) + * Generate hyperlinked source ourselves (#410, part of GSOC 2015) + Changes in version 2.16.0 * Experimental collapsible header support (#335) -- cgit v1.2.3 From d5298da5a2198280347bed9207143e79f44e86ec Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 7 Jul 2015 23:58:33 +0100 Subject: Relax upper bound on GHC a bit --- haddock-api/haddock-api.cabal | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 439c058c..1e0b1eaf 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -47,7 +47,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 - , ghc >= 7.10 && < 7.10.2 + , ghc >= 7.10 && < 7.12 , ghc-paths , haddock-library == 1.2.* @@ -113,8 +113,7 @@ test-suite spec build-depends: base >= 4.3 && < 4.9 , containers - , ghc >= 7.10 && < 7.10.2 - + , ghc >= 7.10 && < 7.12 , hspec , QuickCheck == 2.* -- cgit v1.2.3 From 06e675167cc217d5346d706e0d52af0726710e3d Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 7 Jul 2015 23:58:52 +0100 Subject: Delete trailing whitespace --- haddock-api/resources/html/frames.html | 2 +- haddock-api/resources/html/haddock-util.js | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/HaddockDB.hs | 18 +++++++++--------- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 2 +- haddock-api/src/Haddock/Version.hs | 2 +- haddock-library/LICENSE | 4 ++-- html-test/README.markdown | 2 +- html-test/ref/frames.html | 2 +- html-test/ref/haddock-util.js | 22 +++++++++++----------- html-test/src/Bugs.hs | 2 +- hypsrc-test/ref/src/Classes.html | 2 +- hypsrc-test/src/Classes.hs | 2 +- 12 files changed, 41 insertions(+), 41 deletions(-) diff --git a/haddock-api/resources/html/frames.html b/haddock-api/resources/html/frames.html index 1b4e38d4..e86edb66 100644 --- a/haddock-api/resources/html/frames.html +++ b/haddock-api/resources/html/frames.html @@ -1,4 +1,4 @@ - diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs index 1c248bfb..0bdc9057 100644 --- a/haddock-api/src/Haddock/Backends/HaddockDB.hs +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -40,7 +40,7 @@ ppIfaces mods where do_mod (Module mod, iface) = text " text mod <> text "\">" - $$ text "<literal>" + $$ text "<title><literal>" <> text mod <> text "</literal>" $$ text "" @@ -50,10 +50,10 @@ ppIfaces mods $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "" $$ text "" - + do_export mod decl | (nm:_) <- declBinders decl = text "" + $$ text "" <> do_decl decl <> text "" $$ text "" @@ -63,11 +63,11 @@ ppIfaces mods $$ text "" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype @@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc) @@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty ppHsContext :: HsContext -> Doc ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc @@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) = ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] @@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise + | otherwise = text "" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 5166549a..26bcbf6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -215,7 +215,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ] collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')"; - + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr] diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs index 2ef3a257..4e9a581a 100644 --- a/haddock-api/src/Haddock/Version.hs +++ b/haddock-api/src/Haddock/Version.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Version ( +module Haddock.Version ( projectName, projectVersion, projectUrl ) where diff --git a/haddock-library/LICENSE b/haddock-library/LICENSE index 1636bfcd..460decfc 100644 --- a/haddock-library/LICENSE +++ b/haddock-library/LICENSE @@ -5,11 +5,11 @@ modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR diff --git a/html-test/README.markdown b/html-test/README.markdown index 8d57acab..717bac5c 100644 --- a/html-test/README.markdown +++ b/html-test/README.markdown @@ -1,7 +1,7 @@ This is a testsuite for Haddock that uses the concept of "golden files". That is, it compares output files against a set of reference files. -To add a new test: +To add a new test: 1. Create a module in the `html-test/src` directory. diff --git a/html-test/ref/frames.html b/html-test/ref/frames.html index 1b4e38d4..e86edb66 100644 --- a/html-test/ref/frames.html +++ b/html-test/ref/frames.html @@ -1,4 +1,4 @@ - diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/html-test/ref/haddock-util.js +++ b/html-test/ref/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/html-test/src/Bugs.hs b/html-test/src/Bugs.hs index 8e1f0079..e60bbe8f 100644 --- a/html-test/src/Bugs.hs +++ b/html-test/src/Bugs.hs @@ -1,3 +1,3 @@ module Bugs where -data A a = A a (a -> Int) +data A a = A a (a -> Int) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index a5a3d243..13c8389a 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -408,7 +408,7 @@ >] + > Foo' a where quux :: (a, a) -> a - quux (x, y) = norf [x, y] + quux (x, y) = norf [x, y] norf :: [a] -> a norf = quux . baz . sum . map bar -- cgit v1.2.3 From 5eb0785cde60997f072c3bdfefaf8c389c96d42e Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Wed, 8 Jul 2015 15:03:04 +0200 Subject: StrictData: changes in HsBang type --- haddock-api/src/Haddock/Backends/LaTeX.hs | 10 +++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 86a6909b..d85d75da 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -823,11 +823,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' -ppBang (HsSrcBang _ _ (Just True)) = char '!' -ppBang (HsSrcBang _ _ (Just False)) = char '~' -ppBang _ = empty +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2da4cc1c..21ef167b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,11 +769,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" -ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" -ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" -ppBang _ = noHtml +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c11ca545..edf91ce5 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -269,12 +269,12 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) - HsStrict -> HsSrcBang Nothing (Just False) (Just True) - HsLazy -> HsSrcBang Nothing Nothing Nothing + HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict + HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict + HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness _ -> bang in case src_bang of - (HsSrcBang _ Nothing Nothing) -> tySyn + (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn _ -> noLoc $ HsBangTy bang tySyn ) arg_tys (dataConSrcBangs dc) -- cgit v1.2.3 From 06e0766810779180dbc52d15c0df5a2eaaf1881e Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 11 Jul 2015 14:23:05 +0100 Subject: Fix expansion icon for user-collapsible sections Closes #412 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 5 +++-- html-test/ref/Bug335.html | 6 +++--- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/CHANGES b/CHANGES index ff49b6f5..be829adf 100644 --- a/CHANGES +++ b/CHANGES @@ -23,6 +23,8 @@ Changes in version 2.16.1 * Generate hyperlinked source ourselves (#410, part of GSOC 2015) + * Fix expansion icon for user-collapsible sections (#412) + Changes in version 2.16.0 * Experimental collapsible header support (#335) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index c23f3f08..3fe74a82 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -161,8 +161,9 @@ hackMarkup fmt' h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ False [] <<) + expanded = False + col' = collapseControl id_ expanded "caption" + instTable = (thediv ! collapseSection id_ expanded [] <<) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index 6f3d3820..dbe97422 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -64,7 +64,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");}; >f :: ()

    ExF:

    g :: ()

    ExG:

    Produced by Haddock version 2.16.0
     version 2.16.1
    Date: Wed, 22 Jul 2015 22:03:21 +0100 Subject: Make some version changes after 2.16.1 release --- CHANGES | 10 ++++++---- doc/haddock.xml | 2 +- haddock-api/haddock-api.cabal | 2 +- haddock.cabal | 4 ++-- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/CHANGES b/CHANGES index be829adf..60d39605 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,9 @@ +Changes in version 2.16.2 + + * Generate hyperlinked source ourselves (#410, part of GSOC 2015) + + * Fix expansion icon for user-collapsible sections (#412) + Changes in version 2.16.1 * Don't default to type constructors for out-of-scope names (#253 and @@ -21,10 +27,6 @@ Changes in version 2.16.1 * Fix alignment of Source link for instances in Firefox (#384) - * Generate hyperlinked source ourselves (#410, part of GSOC 2015) - - * Fix expansion icon for user-collapsible sections (#412) - Changes in version 2.16.0 * Experimental collapsible header support (#335) diff --git a/doc/haddock.xml b/doc/haddock.xml index e2845212..e805a437 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -38,7 +38,7 @@ Mateusz Kowalczyk - This document describes Haddock version 2.16.1, a Haskell + This document describes Haddock version 2.16.2, a Haskell documentation tool. diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 1e0b1eaf..4db05de8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,5 +1,5 @@ name: haddock-api -version: 2.16.1 +version: 2.16.2 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/haddock.cabal b/haddock.cabal index 8fa9f33d..27ae8967 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.16.1 +version: 2.16.2 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -59,7 +59,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.9 && < 7.11, + ghc >= 7.9 && < 7.12, bytestring, transformers -- cgit v1.2.3 From 9affe8f6b3a9b07367c8c14162aecea8b15856a6 Mon Sep 17 00:00:00 2001 From: randen Date: Thu, 30 Jul 2015 14:49:08 -0700 Subject: Break the response file by line termination rather than spaces, since spaces may be within the parameters. This simple approach avoids having the need for any quoting and/or escaping (although a newline char will not be possible in a parameter and has no escape mechanism to allow it). --- driver/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/driver/Main.hs b/driver/Main.hs index 5097a86d..ccbb8b7d 100644 --- a/driver/Main.hs +++ b/driver/Main.hs @@ -20,7 +20,7 @@ expandResponse :: [String] -> IO [String] expandResponse = fmap concat . mapM expand where expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . filter (not . null) . words + expand ('@':f) = readFileExc f >>= return . filter (not . null) . lines expand x = return [x] readFileExc f = -- cgit v1.2.3 From 3436273f6e87d9358f6c23ad5b6b2838ce573892 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 26 Jul 2015 22:19:40 +0200 Subject: Replace (SourceText,FastString) with WithSourceText data type Phab:D907 introduced SourceText for a number of data types, by replacing FastString with (SourceText,FastString). Since this has an Outputable instance, no warnings are generated when ppr is called on it, but unexpected output is generated. See Phab:D1096 for an example of this. Replace the (SourceText,FastString) tuples with a new data type data WithSourceText = WithSourceText SourceText FastString Trac ticket: #10692 --- haddock-api/src/Haddock/Interface/Create.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5adaef69..ab79fb8d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -45,6 +45,7 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) +import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -158,7 +159,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - fmap snd $ ideclPkgQual impDecl) + fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -194,8 +195,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From 089d20c23c5e3a00856ee9480a3953060b03ed7b Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 31 Jul 2015 09:47:43 +0100 Subject: Update changelog --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index 60d39605..d35528d1 100644 --- a/CHANGES +++ b/CHANGES @@ -4,6 +4,8 @@ Changes in version 2.16.2 * Fix expansion icon for user-collapsible sections (#412) + * Break up response file arguments on newlines + Changes in version 2.16.1 * Don't default to type constructors for out-of-scope names (#253 and -- cgit v1.2.3 From 7656bf86a661c5c755dc9874f709df2fc4833257 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sun, 14 Jun 2015 23:12:09 -0400 Subject: Avoid JavaScript error during page load in non-frame mode In non-frame mode, parent.window.synopsis refers to the synopsis div rather than the nonexistent frame. Unfortunately, the script wrongly assumes that if it exists it must be a frame, leading to an error where it tries to access the nonexistent attribute 'replace' of an undefined value (synopsis.location). Closes #406 --- haddock-api/resources/html/haddock-util.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index ba574356..fc7743fe 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -229,7 +229,7 @@ function perform_search(full) } function setSynopsis(filename) { - if (parent.window.synopsis) { + if (parent.window.synopsis && parent.window.synopsis.location) { if (parent.window.synopsis.location.replace) { // In Firefox this avoids adding the change to the history. parent.window.synopsis.location.replace(filename); -- cgit v1.2.3 From ecabf4e16d72818d39d0a18c9a64cb1d464b87b5 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 15 Jun 2015 00:06:08 -0400 Subject: Link to the definitions to themselves Currently, the definitions already have an anchor tag that allows URLs with fragment identifiers to locate them, but it is rather inconvenient to obtain such a URL (so-called "permalink") as it would require finding the a link to the corresponding item in the Synopsis or elsewhere. This commit adds hyperlinks to the definitions themselves, allowing users to obtain links to them easily. To preserve the original aesthetics of the definitions, we alter the color of the link so as to be identical to what it was, except it now has a hover effect indicating that it is clickable. Additionally, the anchor now uses the 'id' attribute instead of the (obsolete) 'name' attribute. Closes #407 --- .../resources/html/Ocean.std-theme/ocean.css | 3 +++ haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 21 +++++++++++++-------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 1110b407..1cc55cb6 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -41,6 +41,9 @@ a[href]:link { color: rgb(196,69,29); } a[href]:visited { color: rgb(171,105,84); } a[href]:hover { text-decoration:underline; } +a[href].def:link, a[href].def:visited { color: black; } +a[href].def:hover { color: rgb(78, 98, 114); } + /* @end */ /* @group Fonts & Sizes */ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index cf12da40..c69710d1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n -ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Prefix n +ppBinder = ppBinderWith Prefix ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n -ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Infix n +ppBinderInfix = ppBinderWith Infix + +ppBinderWith :: Notation -> Bool -> OccName -> Html +-- 'isRef' indicates whether this is merely a reference from another part of +-- the documentation or is the actual definition; in the latter case, we also +-- set the 'id' and 'class' attributes. +ppBinderWith notation isRef n = + linkedAnchor name ! attributes << ppBinder' notation n + where + name = nameAnchorId n + attributes | isRef = [] + | otherwise = [identifier name, theclass "def"] ppBinder' :: Notation -> OccName -> Html ppBinder' notation n = wrapInfix notation n $ ppOccName n -- cgit v1.2.3 From e190efe089a0bd038c7de41c1c52ef580e52712c Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sun, 14 Jun 2015 22:47:13 -0400 Subject: Fix typo in Haddock.Backends.Xhtml.Layout: divSynposis -> divSynopsis Closes #408 --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 90cb9fa4..e5e4db3f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -546,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual synopsis | no_doc_at_all = noHtml | otherwise - = divSynposis $ + = divSynopsis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode qual) exports diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 914a7a7e..e79c2c3d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout ( miniBody, divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList, sectionName, @@ -76,7 +76,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList :: Html -> Html @@ -86,7 +86,7 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" divDescription = sectionDiv "description" -divSynposis = sectionDiv "synopsis" +divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" -- cgit v1.2.3 From c274363d5d868c838c382a52428c667090514f86 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 27 Jul 2015 05:58:58 -0400 Subject: Fix record field alignment when name is too long Change
    to
      and use display:table rather than floats to layout the record fields. This avoids bug #301 that occurs whenever the field name gets too long. Slight aesthetic change: the entire cell of the field's source code is now shaded gray rather than just the area where text exists. Fixes #301. Closes #421 --- .../resources/html/Ocean.std-theme/ocean.css | 29 +++++++++++----------- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 10 +++----- 2 files changed, 19 insertions(+), 20 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 1cc55cb6..9ad9f9d2 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -427,30 +427,31 @@ div#style-menu-holder { visibility: hidden; } -.subs dl { +.subs ul { + list-style: none; + display: table; margin: 0; } -.subs dt { - float: left; - clear: left; - display: block; +.subs ul li { + display: table-row; +} + +.subs ul li dfn { + display: table-cell; + font-style: normal; + font-weight: bold; margin: 1px 0; + white-space: nowrap; } -.subs dd { - float: right; - width: 90%; - display: block; +.subs ul li > .doc { + display: table-cell; padding-left: 0.5em; margin-bottom: 0.5em; } -.subs dd.empty { - display: none; -} - -.subs dd p { +.subs ul li > .doc p { margin: 0; } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e79c2c3d..4714c1b6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -127,14 +127,12 @@ divSubDecls cssClass captionName = maybe noHtml wrap subDlist :: Qualification -> [SubDecl] -> Maybe Html subDlist _ [] = Nothing -subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv +subDlist qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = - dterm ! [theclass "src"] << decl - +++ - docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) - - clearDiv = thediv ! [ theclass "clear" ] << noHtml + li << + (define ! [theclass "src"] << decl +++ + docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) subTable :: Qualification -> [SubDecl] -> Maybe Html -- cgit v1.2.3 From 7e8330944666064f12f067970de2936b58589785 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 18:54:30 +0200 Subject: Add some utility definitions for generating line anchors. --- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 25 ++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index db2bfc76..9de4a03d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,13 +1,18 @@ module Haddock.Backends.Hyperlinker.Utils ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' - , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl - , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, + , hypSrcModuleUrl, hypSrcModuleUrl' + , hypSrcNameUrl + , hypSrcLineUrl + , hypSrcModuleNameUrl, hypSrcModuleLineUrl + , hypSrcModuleUrlFormat + , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat ) where import Haddock.Backends.Xhtml.Utils import GHC +import FastString import System.FilePath.Posix (()) @@ -31,17 +36,33 @@ hypSrcNameUrl :: Name -> String hypSrcNameUrl name = spliceURL Nothing Nothing (Just name) Nothing nameFormat +hypSrcLineUrl :: Int -> String +hypSrcLineUrl line = spliceURL + Nothing Nothing Nothing (Just spn) lineFormat + where + loc = mkSrcLoc nilFS line 1 + spn = mkSrcSpan loc loc + hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +hypSrcModuleLineUrl :: Module -> Int -> String +hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line + hypSrcModuleUrlFormat :: String hypSrcModuleUrlFormat = hypSrcDir moduleFormat hypSrcModuleNameUrlFormat :: String hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat +hypSrcModuleLineUrlFormat :: String +hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat + moduleFormat :: String moduleFormat = "%{MODULE}.html" nameFormat :: String nameFormat = "%{NAME}" + +lineFormat :: String +lineFormat = "line-%{LINE}" -- cgit v1.2.3 From 241346e4e275bdde2d28f90df3225057f4a09cfc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 19:48:08 +0200 Subject: Make hyperlinked source renderer generate line anchors. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 26 +++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 5037421a..15793f0c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} + + module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -78,10 +81,11 @@ header mcss mjs = tokenGroup :: SrcMap -> TokenGroup -> Html -tokenGroup _ (GrpNormal tok) = - tokenSpan tok ! attrs +tokenGroup _ (GrpNormal tok@(Token { .. })) + | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | otherwise = tokenSpan tok ! attrs where - attrs = [ multiclass . tokenStyle . tkType $ tok ] + attrs = [ multiclass . tokenStyle $ tkType ] tokenGroup srcs (GrpRich det tokens) = externalAnchor det . internalAnchor det . hyperlink srcs det $ content where @@ -167,3 +171,19 @@ externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleUrl' name ] Nothing -> content + + +renderSpace :: Int -> String -> Html +renderSpace _ [] = Html.noHtml +renderSpace line ('\n':rest) = mconcat + [ Html.thespan . Html.toHtml $ "\n" + , lineAnchor (line + 1) + , renderSpace (line + 1) rest + ] +renderSpace line space = + let (hspace, rest) = span (/= '\n') space + in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest + + +lineAnchor :: Int -> Html +lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] -- cgit v1.2.3 From 7eafa83ffaf535ae8c1a038f004a254192d08afc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 20:08:46 +0200 Subject: Re-accept test cases after adding line anchors for each of them. --- hypsrc-test/ref/src/Classes.html | 498 +++++++++++++++++++++------------- hypsrc-test/ref/src/Constructors.html | 402 +++++++++++++++++---------- hypsrc-test/ref/src/Identifiers.html | 422 ++++++++++++++++------------ hypsrc-test/ref/src/Literals.html | 172 +++++++----- hypsrc-test/ref/src/Operators.html | 288 ++++++++++++-------- hypsrc-test/ref/src/Records.html | 448 ++++++++++++++++++------------ hypsrc-test/ref/src/Types.html | 454 +++++++++++++++++++------------ 7 files changed, 1673 insertions(+), 1011 deletions(-) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 13c8389a..74a7a427 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -9,22 +9,32 @@ >
      module Classes where
-
-
 
+
+class Foo a where
-        bar :: a -> Int
-        baz :: Int -> (, )
-
 
+instance Foo Int where
-        bar = id
-        baz x = (, )
-
 
+instance Foo [] where
-        bar = length
-        baz _ = (], [])
+
-
-
 
+class Foo a => Foo' a where
-        quux :: (, ) -> a
-        quux (, ) = norf [, ]
-
-    
+    norf :: [] -> a
-        norf = quux . baz . sum . map bar
+
-
 instance Foo' Int where
-        norf = sum
+
-
 instance Foo' [] where
-        quux = uncurry (++)
+
+
-
-
 class Plugh p where
-        plugh :: p a a -> p b b -> p (a -> ) (b -> )
+
-
 instance Plugh Either where
-        plugh (Left ) _ = Right $ const a
-        plugh (Right ) _ = Right $ const a
-        plugh _ (Left ) = Left $ const b
-        plugh _ (Right ) = Left $ const b
 
      module Constructors where
-
-
 
+
+data Foo
-        = Bar
-        | Baz
-        | Quux Foo Int
-
 
+newtype Norf = Norf (, [], )
+
-
-
 
+bar, baz, quux :: Foo
 bar = Bar
 baz = Baz
 quux = Quux quux 0
+
-
-
 
+unfoo :: Foo -> Int
 unfoo Bar = 0
 unfoo Baz = 0
 unfoo (Quux foo ) = 42 * n + unfoo foo
+
-
-
 
+unnorf :: Norf -> []
 unnorf (Norf (, , )) = xs
 unnorf (Norf (, , )) = reverse xs
 unnorf _ = undefined
+
+
-
-
 unnorf' :: Norf -> Int
 unnorf' Norf (Quux _ ), _, Quux f3 _)) =
-        x' + n * unfoo f1 + aux f3
-    where
-        aux fx = unfoo f2 * unfoo fx * unfoo f3
-        x' = sum . map unfoo . unnorf $ x
 
      module Identifiers where
-
-
 
+
+foo, bar, baz :: Int -> Int -> Int
 foo x y = x + x * bar y x * y + y
 bar x y = y + x - baz x y - x + y
 baz x y = x * y * y * y * x
+
-
 quux :: Int -> Int
 quux x = foo (bar x ) (bar x )
-
 
+norf :: Int -> Int -> Int -> Int
 norf x y z
-        | x < 0 = quux x
-        | y < 0 = quux y
-        | z < 0 = quux z
-        | otherwise = norf () () ()
-
-
 
+
+main :: IO ()
 main = do
-        putStrLn . show $ foo x y
-        putStrLn . show $ quux z
-        putStrLn . show $ norf x y z
-    where
-        x = 10
-        y = 20
-        z = 30
 
      module Literals where
-
-
 
+
+str :: String
 str = "str literal"
+
-
 num :: Num a => a
 num = 0 + 1 + 1010011 * 41231 + 12131
-
 
+frac :: Fractional a => a
 frac = 42.0000001
+
-
 list :: []]
 list = [], [], []]
+
-
 pair :: (), (), (), (), ())
 pair = (), (), (), (), ())
 
      module Operators where
-
-
 
+
+(+++) :: [] -> [] -> []
 a +++ b = a ++ b ++ a
-
 
+($$$) :: [] -> [] -> []
 a $$$ b = b +++ a
+
-
 (***) :: [] -> [] -> []
 () a [] = a
 (***) a () = a +++ (a *** )
-
 
+(*/\*) :: []] -> [] -> []
 a */\* b = concatMap (*** ) a
+
-
 (**/\**) :: []] -> []] -> []]
 a **/\** b = zipWith () [a +++ ] (a $$$ )
+
+
-
-
 (#.#) :: a -> b -> (c -> (, ))
 a #.# b = const $ (, )
 
      {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
-
-
 
+
+module Records where
+
+
-
-
 data Point = Point
-        { x :: !Int
-        , y :: !Int
-        }
+
+
-
-
 point :: Int -> Int -> Point
 point x y = Point { x = , y = y }
-
-
 
+
+lengthSqr :: Point -> Int
 lengthSqr (Point { x = , y = y }) = x * x + y * y
+
-
 lengthSqr' :: Point -> Int
 lengthSqr' (Point { , y }) = y * y + x * x
+
-
-
 
+translateX, translateY :: Point -> Int -> Point
 translateX p d = p { x = x p + d }
 translateY p d = p { y = y p + d }
+
-
 translate :: Int -> Int -> Point -> Point
 translate x y p =
-        aux p
-    where
-        (, ) = (, )
-        aux ..} = p { x = x + , y = y + dy }
 
      {-# LANGUAGE TypeFamilies #-}
-
-
 
+
+module Types where
-
-
 
+
+data Quux = Bar | Baz
+
-
 newtype Foo = Foo ()
+
-
 type FooQuux = (, )
 type QuuxFoo = (, )
+
-
-
 
+data family Norf a b
+
-
 data instance Norf Foo Quux = NFQ Foo Quux
 data instance Norf Quux Foo = NQF Quux Foo
-
-
 
+
+type family Norf' a b
-
 
+type instance Norf' Foo Quux = (, )
 type instance Norf' Quux Foo = (, )
+
+
-
-
 norf1 :: Norf Foo Quux -> Int
 norf1 (NFQ (Foo ()) ) = 0
 norf1 (NFQ (Foo ()) ) = 1
+
-
 norf2 :: Norf Quux Foo -> Int
 norf2 (NQF Bar (Foo ()) = 0
 norf2 (NQF Baz (Foo ()) = 1
+
-
-
 
+norf1' :: Norf' Foo Quux -> Int
 norf1' (Foo (), ) = 0
 norf1' (Foo (), ) = 1
+
-
 norf2' :: Norf' Quux Foo -> Int
 norf2' (, Foo ()) = 0
 norf2' (, Foo ()) = 1
      Date: Sat, 25 Jul 2015 20:49:17 +0200 Subject: Override source line flags when source hyperlinker is enabled. --- haddock-api/src/Haddock.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 350a73ea..8f327b09 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -280,8 +280,13 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap - srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap') + pkgSrcLMap' + | Flag_HyperlinkedSource `elem` flags = + Map.singleton pkgKey hypSrcModuleLineUrlFormat + | Just path <- srcLEntity = Map.singleton pkgKey path + | otherwise = Map.empty + + sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags -- cgit v1.2.3 From 2b2e3108e892b925abeb101609d3e49ec69ef4dc Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sun, 2 Aug 2015 23:58:25 +0100 Subject: Update tests to follow HTML changes --- CHANGES | 4 + html-test/ref/A.html | 16 +- html-test/ref/AdvanceTypes.html | 8 +- html-test/ref/B.html | 10 +- html-test/ref/Bold.html | 4 +- html-test/ref/Bug1.html | 6 +- html-test/ref/Bug195.html | 136 +++--- html-test/ref/Bug2.html | 4 +- html-test/ref/Bug201.html | 6 +- html-test/ref/Bug253.html | 4 +- html-test/ref/Bug26.html | 10 +- html-test/ref/Bug294.html | 18 +- html-test/ref/Bug298.html | 12 +- html-test/ref/Bug3.html | 4 +- html-test/ref/Bug308.html | 6 +- html-test/ref/Bug308CrossModule.html | 4 +- html-test/ref/Bug310.html | 4 +- html-test/ref/Bug313.html | 6 +- html-test/ref/Bug335.html | 6 +- html-test/ref/Bug387.html | 6 +- html-test/ref/Bug4.html | 4 +- html-test/ref/Bug6.html | 88 ++-- html-test/ref/Bug7.html | 8 +- html-test/ref/Bug8.html | 18 +- html-test/ref/Bug85.html | 14 +- html-test/ref/BugDeprecated.html | 14 +- html-test/ref/BugExportHeadings.html | 14 +- html-test/ref/Bugs.html | 6 +- html-test/ref/DeprecatedClass.html | 10 +- html-test/ref/DeprecatedData.html | 14 +- html-test/ref/DeprecatedFunction.html | 6 +- html-test/ref/DeprecatedFunction2.html | 4 +- html-test/ref/DeprecatedFunction3.html | 4 +- html-test/ref/DeprecatedModule.html | 4 +- html-test/ref/DeprecatedModule2.html | 4 +- html-test/ref/DeprecatedNewtype.html | 10 +- html-test/ref/DeprecatedReExport.html | 4 +- html-test/ref/DeprecatedRecord.html | 60 +-- html-test/ref/DeprecatedTypeFamily.html | 6 +- html-test/ref/DeprecatedTypeSynonym.html | 6 +- html-test/ref/Examples.html | 4 +- html-test/ref/Extensions.html | 4 +- html-test/ref/FunArgs.html | 12 +- html-test/ref/GADTRecords.html | 64 +-- html-test/ref/Hash.html | 14 +- html-test/ref/HiddenInstances.html | 6 +- html-test/ref/HiddenInstancesB.html | 6 +- html-test/ref/Hyperlinks.html | 4 +- html-test/ref/IgnoreExports.html | 6 +- html-test/ref/ImplicitParams.html | 12 +- html-test/ref/Minimal.html | 52 +-- html-test/ref/ModuleWithWarning.html | 4 +- html-test/ref/NamedDoc.html | 2 +- html-test/ref/Nesting.html | 18 +- html-test/ref/NoLayout.html | 4 +- html-test/ref/NonGreedy.html | 4 +- html-test/ref/Operators.html | 44 +- html-test/ref/PatternSyns.html | 22 +- html-test/ref/Properties.html | 4 +- html-test/ref/PruneWithWarning.html | 2 +- html-test/ref/QuasiExpr.html | 28 +- html-test/ref/QuasiQuote.html | 4 +- html-test/ref/SpuriousSuperclassConstraints.html | 4 +- html-test/ref/TH.html | 4 +- html-test/ref/TH2.html | 4 +- html-test/ref/Test.html | 522 ++++++++++++----------- html-test/ref/Threaded.html | 16 +- html-test/ref/Ticket112.html | 4 +- html-test/ref/Ticket61.html | 6 +- html-test/ref/Ticket75.html | 8 +- html-test/ref/TitledPicture.html | 6 +- html-test/ref/TypeFamilies.html | 76 ++-- html-test/ref/TypeFamilies2.html | 12 +- html-test/ref/TypeOperators.html | 44 +- html-test/ref/Unicode.html | 4 +- html-test/ref/Visible.html | 4 +- html-test/ref/haddock-util.js | 2 +- html-test/ref/mini_FunArgs.html | 18 + html-test/ref/ocean.css | 32 +- 79 files changed, 853 insertions(+), 805 deletions(-) diff --git a/CHANGES b/CHANGES index d35528d1..2cb0a5e0 100644 --- a/CHANGES +++ b/CHANGES @@ -6,6 +6,10 @@ Changes in version 2.16.2 * Break up response file arguments on newlines + * Various HTML fixes (#301, #406, #407, #421) + + * Line anchors in hyperlinked source (#420) + Changes in version 2.16.1 * Don't default to type constructors for out-of-scope names (#253 and diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 96e2d001..56c04bc6 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -88,7 +88,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >

      data A

    data Bar W = BarX Zdata Bar W = BarX Z

    Shown because BarX is still exported despite Z being hidden

    data Bar Ydata Bar Y 
    A

    other :: Int

    test2 :: Bool

    data X

    X

    reExport :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data Pattern :: [*] -> * where
    Nil :: Pattern
    Cons :: Maybe

    Produced by Haddock version 2.15.0

    version 2.16.2

    test :: Int

    reExport :: Int

    data X

    X

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: t

    Produced by Haddock version 2.15.0

    version 2.16.2

    data T

    T

    Produced by Haddock version 2.15.0

    version 2.16.2

    data T

    Produced by Haddock version 2.16.0

    version 2.16.2

    Documentation

    x :: A

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f :: ()

    g :: ()

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: ()

    Produced by Haddock version 2.16.0

    version 2.16.2

    Documentation

    f :: ()

    g :: ()

    class C a where

    Methods

    c_f :: a

    Produced by Haddock version 2.16.1

    version 2.16.2

    data A

    DP A = = ProblemCtor' Adata TP A = = ProblemCtor A

    problemField :: TO A

    problemField' :: DO A

    gadtField :: GADT A

    data family DP t :: *

    DP A = = ProblemCtor' A

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    (<^>) :: (a -> a) -> a -> a

    (<^) :: a -> a -> a

    (^>) :: a -> a -> a

    (⋆^) :: a -> a -> a

    f :: ()

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f :: ()

    g :: ()

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    h :: ()

    Produced by Haddock version 2.15.0

    version 2.16.2

    type family a a + b :: Nat

    Produced by Haddock version 2.16.0

    version 2.16.2

    Documentation

    a :: a

    b :: a

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f :: ()

    g :: ()

    Produced by Haddock version 2.16.1

    version 2.16.2

    test1 :: Int

    test2 :: Int

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data A

    A

    Fields

    someField :: ()

    Doc for someField of A

    someOtherField :: ()

    Doc for someOtherField of A

    B

    Fields

    someField :: ()

    Doc for someField of A

    someOtherField :: ()

    Doc for someOtherField of A

    C

    Fields

    someField :: ()

    Doc for someField of A

    someOtherField :: ()

    Doc for someOtherField of A

    A Int

    data B

    data C

    B

    Fields

    b :: Int
     

    data D

    C

    Fields

    c1 :: Int
     
    c2 :: Int
     
    D Int

    newtype E

    E Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data Foo

    Foo

    class Bar x y

    Produced by Haddock version 2.16.1

    version 2.16.2

    data Typ

    Type (Typ
    TFree (Typ

    (-->) :: t -> t1 -> Typ

    (--->) :: Foldable

    s :: t

    t :: t

    main :: t

    Produced by Haddock version 2.16.0

    version 2.16.2

    data Foo :: (* -> *) -> * -> * where
    Bar :: f x -> Foo

    data Baz :: * where
    Baz' :: Baz

    data Qux where
    Quux :: Qux

    Produced by Haddock version 2.16.0

    version 2.16.2

    Documentation

    foo :: Int

    bar :: Int

    baz :: Int

    one :: Int

    two :: Int

    three :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Foo

    foo :: IntBar

    bar :: IntBaz

    baz :: IntOne

    one :: IntTwo

    two :: IntThree

    three :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data A a

    A a (a -> Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    class SomeClass a where

    Methods

    foo :: a -> a

    class SomeOtherClass a where

    Methods

    bar :: a -> a

    Produced by Haddock version 2.15.0

    version 2.16.2

    data Foo

    Foo
    Bar

    data One

    One
    Two

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    bar :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Integer

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    newtype SomeNewType

    Date: Fri, 31 Jul 2015 20:16:33 +0200 Subject: Make identifier generation also architecture-independent. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 ++++--- html-test/ref/Bug7.html | 8 ++--- html-test/ref/Hash.html | 8 ++--- html-test/ref/HiddenInstances.html | 16 +++++----- html-test/ref/HiddenInstancesB.html | 8 ++--- html-test/ref/QuasiExpr.html | 4 +-- html-test/ref/SpuriousSuperclassConstraints.html | 8 ++--- html-test/ref/Test.html | 4 +-- html-test/ref/TypeFamilies.html | 40 ++++++++++++------------ 9 files changed, 55 insertions(+), 53 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c30d0e62..f1203210 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -31,10 +31,12 @@ import Haddock.Syb import Haddock.Doc (combineDocumentation) import Data.Bits +import Data.Char import Data.Data (Data, cast) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe +import Data.Word import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -636,16 +638,16 @@ instanceId orgin no ihd = concat -- section anchors in testing framework and that is not only inconvenient but -- also makes testing less viable. And it is only temporary solution so we can -- live with it. -instHeadId :: InstHead DocName -> Int +instHeadId :: InstHead DocName -> Word64 instHeadId (InstHead { .. }) = - djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds + djb2 id . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds where names = everything (++) $ maybeToList . (cast :: forall a. Data a => a -> Maybe DocName) - key = djb2 . occNameString . nameOccName . getName + key = djb2 (fromIntegral . ord) . occNameString . nameOccName . getName - djb2 :: Enum a => [a] -> Int - djb2 = foldl (\h c -> h * 33 `xor` fromEnum c) 5381 + djb2 :: (a -> Word64) -> [a] -> Word64 + djb2 conv = foldl (\h c -> h * 33 `xor` conv c) 5381 ------------------------------------------------------------------------------- diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html index f0fbc44d..4c0ba83b 100644 --- a/html-test/ref/Bug7.html +++ b/html-test/ref/Bug7.html @@ -106,7 +106,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");}; > Date: Mon, 3 Aug 2015 15:29:35 +0200 Subject: Fix issue with instance expander hijacking type hyperlink click. --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 2 ++ haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 428040bc..139335ac 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -159,6 +159,8 @@ p.caption.expander { .instance.collapser, .instance.expander { margin-left: 0px; background-position: left center; + min-width: 9px; + min-height: 9px; } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 074b6801..d624a1d0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -205,9 +205,9 @@ subInstHead :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) -> Html subInstHead iid hdr = - expander << hdr + expander noHtml <+> hdr where - expander = thediv ! collapseControl (instAnchorId iid) False "instance" + expander = thespan ! collapseControl (instAnchorId iid) False "instance" subInstDetails :: String -- ^ Instance unique id (for anchor generation) -- cgit v1.2.3 From 2f0d25e3d3f15b05f904fd3ca74e567f2fec4b93 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 3 Aug 2015 15:47:53 +0200 Subject: Get rid of dreadful hashing function for generating identifiers. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 77 +++++++++----------------- 1 file changed, 26 insertions(+), 51 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f1203210..20ca8e2b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,16 +27,11 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types -import Haddock.Syb import Haddock.Doc (combineDocumentation) -import Data.Bits -import Data.Char -import Data.Data (Data, cast) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe -import Data.Word import Text.XHtml hiding ( name, title, p, quote ) import GHC @@ -297,7 +292,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances links OriginFamily instances docname splice unicode qual + = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -533,31 +528,42 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances links OriginClass instances nm + instancesBit = ppInstances links (OriginClass nm) instances splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -data InstOrigin = OriginClass | OriginData | OriginFamily +data InstOrigin name + = OriginClass name + | OriginData name + | OriginFamily name + + +instance NamedThing name => NamedThing (InstOrigin name) where + + getName (OriginClass name) = getName name + getName (OriginData name) = getName name + getName (OriginFamily name) = getName name ppInstances :: LinksInfo - -> InstOrigin -> [DocInstance DocName] -> DocName + -> InstOrigin DocName -> [DocInstance DocName] -> Splice -> Unicode -> Qualification -> Html -ppInstances links origin instances baseName splice unicode qual +ppInstances links origin instances splice unicode qual = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where - instName = getOccString $ getName baseName + instName = getOccString origin instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = ((ppInstHead links splice unicode qual mdoc origin no inst), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName + -> Maybe (MDoc DocName) + -> InstOrigin DocName -> Int -> InstHead DocName -> SubDecl ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = case ihdInstType of @@ -606,48 +612,17 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin -> Int -> InstHead DocName -> String -instanceId orgin no ihd = concat - [ qual orgin +instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String +instanceId origin no ihd = concat + [ qual origin + , ":" ++ getOccString origin , ":" ++ (occNameString . getOccName . ihdClsName) ihd - , ":" ++ show (instHeadId ihd) , ":" ++ show no ] where - qual OriginClass = "ic" - qual OriginData = "id" - qual OriginFamily = "if" - - --- | Compute unique identifier for given instance. --- --- This is rather poor way of doing it. Ideally, we would like to have --- everything wrapped in a stateful monad that allows us to generate unique --- identifiers as needed. Since introducing such monad would require major --- refactoring, for now we just generate naive hash for given instance. --- --- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea --- for such simple hash function (djb2) is stolen from --- . --- --- Hashing is performed on string representation of `Name`. Why string instead --- of 'Unique' of that 'Name'? That would be much faster and nicer, yes. --- However, 'Unique' is not very deterministic, so running it on different --- configurations would yield different HTML documents. This is not very bad, --- as nobody cares about these identifiers but it would require us to strip --- section anchors in testing framework and that is not only inconvenient but --- also makes testing less viable. And it is only temporary solution so we can --- live with it. -instHeadId :: InstHead DocName -> Word64 -instHeadId (InstHead { .. }) = - djb2 id . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds - where - names = everything (++) $ - maybeToList . (cast :: forall a. Data a => a -> Maybe DocName) - key = djb2 (fromIntegral . ord) . occNameString . nameOccName . getName - - djb2 :: (a -> Word64) -> [a] -> Word64 - djb2 conv = foldl (\h c -> h * 33 `xor` conv c) 5381 + qual (OriginClass _) = "ic" + qual (OriginData _) = "id" + qual (OriginFamily _) = "if" ------------------------------------------------------------------------------- @@ -715,7 +690,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances links OriginData instances docname + instancesBit = ppInstances links (OriginData docname) instances splice unicode qual -- cgit v1.2.3 From e46cf071f018a1145ed96c463375c42d40382e35 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 3 Aug 2015 15:54:18 +0200 Subject: Move `InstOrigin` type declaration to more appropriate module. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 ------------- haddock-api/src/Haddock/Types.hs | 18 ++++++++++++++++++ 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 20ca8e2b..e536ae4b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -534,19 +534,6 @@ ppClassDecl summary links instances fixities loc d subdocs ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -data InstOrigin name - = OriginClass name - | OriginData name - | OriginFamily name - - -instance NamedThing name => NamedThing (InstOrigin name) where - - getName (OriginClass name) = getName name - getName (OriginData name) = getName name - getName (OriginFamily name) = getName name - - ppInstances :: LinksInfo -> InstOrigin DocName -> [DocInstance DocName] -> Splice -> Unicode -> Qualification diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 1f074ac3..106d3544 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -384,6 +384,24 @@ data InstHead name = InstHead , ihdInstType :: InstType name } + +-- | An instance origin information. +-- +-- This is used primarily in HTML backend to generate unique instance +-- identifiers (for expandable sections). +data InstOrigin name + = OriginClass name + | OriginData name + | OriginFamily name + + +instance NamedThing name => NamedThing (InstOrigin name) where + + getName (OriginClass name) = getName name + getName (OriginData name) = getName name + getName (OriginFamily name) = getName name + + ----------------------------------------------------------------------------- -- * Documentation comments ----------------------------------------------------------------------------- -- cgit v1.2.3 From a24cc753ab35af1b2abfb523a835624484cf71d1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 3 Aug 2015 16:05:01 +0200 Subject: Accept tests affected by changes related to instance expander. --- html-test/ref/Bug26.html | 10 +- html-test/ref/Bug7.html | 36 +++--- html-test/ref/Hash.html | 46 +++---- html-test/ref/HiddenInstances.html | 56 ++++---- html-test/ref/HiddenInstancesB.html | 28 ++-- html-test/ref/QuasiExpr.html | 28 ++-- html-test/ref/SpuriousSuperclassConstraints.html | 32 ++--- html-test/ref/Test.html | 28 ++-- html-test/ref/TypeFamilies.html | 156 +++++++++++------------ 9 files changed, 210 insertions(+), 210 deletions(-) diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index 18bfa63b..bdb51231 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -147,11 +147,11 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug26.html");}; > Date: Wed, 5 Aug 2015 21:08:42 +0200 Subject: Add examples with type operators to the instances test case. --- html-test/src/Instances.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index b7bc8921..545c8534 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -3,11 +3,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Instances where +newtype (<~~) a b = Xyzzy (b -> (a, a)) + + class Foo f where foo :: f Int -> a -> f a @@ -21,6 +25,8 @@ instance Foo [] instance (Eq a, Foo f) => Foo ((,) (f a)) instance Foo (Either a) instance Foo ((,,) a a) +instance Foo ((->) a) +instance Foo ((<~~) a) class Foo f => Bar f a where -- cgit v1.2.3 From 809a24cc74b4ca23e69f2f4a857e31c5a440b436 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 21:30:59 +0200 Subject: Add basic support for sugaring infix type operators. --- haddock-api/src/Haddock/Interface/Specialize.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 59985de6..ddae2b93 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -116,7 +116,7 @@ sugar = everywhere $ mkT step where step :: HsType name -> HsType name - step = sugarTuples . sugarLists + step = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing name => HsType name -> HsType name @@ -145,6 +145,12 @@ sugarTuples typ = aux _ _ = typ +sugarOperators :: NamedThing name => HsType name -> HsType name +sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb) + | isSymOcc $ getOccName name = mkHsOpTy la (L loc name) lb +sugarOperators typ = typ + + -- | Compute arity of given tuple operator. -- -- >>> parseTupleArity "(,,)" -- cgit v1.2.3 From ac1894067ce7bc5c34f1cd4d70c9e7fbeb6ae6dc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 13:10:09 +0200 Subject: Add support for sugaring built-in function syntax. --- haddock-api/src/Haddock/Interface/Specialize.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index ddae2b93..d6466570 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -147,7 +147,10 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb) - | isSymOcc $ getOccName name = mkHsOpTy la (L loc name) lb + | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + where + name' = getName name sugarOperators typ = typ -- cgit v1.2.3 From d4a48a121abb581611f4dd21a5c80d19cc5cf712 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 7 Aug 2015 16:11:30 +0200 Subject: Remove default methods from Hoogle class output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 914e3466..f174ebcf 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -20,6 +20,8 @@ import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) + +import Bag import GHC import Outputable @@ -154,9 +156,11 @@ ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : +ppClass dflags x subdocs = out dflags decl' : concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) where + decl' = x { tcdSigs = [], tcdMeths = emptyBag } + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" -- cgit v1.2.3 From 19205c89ea272faf3db38f9d3e219342db260efb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 7 Aug 2015 17:06:58 +0200 Subject: Add fixity declarations in Hoogle backend output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f174ebcf..04f266af 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -28,6 +28,7 @@ import Outputable import Data.Char import Data.List import Data.Maybe +import qualified Data.Map as Map import Data.Version import System.FilePath import System.IO @@ -57,7 +58,8 @@ ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags) (ifaceInstances iface) ++ + concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface) --------------------------------------------------------------------- @@ -234,6 +236,10 @@ ppCtor dflags dat subdocs con ResTyGADT _ x -> x +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] + + --------------------------------------------------------------------- -- DOCUMENTATION -- cgit v1.2.3 From d070abf3e2348d02f8698c653ca2247e913d222e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 7 Aug 2015 18:29:55 +0200 Subject: Fix bug with incorrect fixities being generated in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 04f266af..cd015c03 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -28,7 +28,6 @@ import Outputable import Data.Char import Data.List import Data.Maybe -import qualified Data.Map as Map import Data.Version import System.FilePath import System.IO @@ -58,8 +57,7 @@ ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) ++ - concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface) + concatMap (ppInstance dflags) (ifaceInstances iface) --------------------------------------------------------------------- @@ -124,6 +122,7 @@ ppExport :: DynFlags -> ExportItem Name -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs + , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs @@ -131,8 +130,10 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (SigD sig) = ppSig dflags sig + f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] + + ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] -- cgit v1.2.3 From ff8464058e226f3f2cdf7df4b0f395ba826d5190 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 10 Aug 2015 14:05:23 +0200 Subject: Improve class type family declarations output in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index cd015c03..0a174fd6 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -159,10 +159,17 @@ ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags x subdocs = out dflags decl' : - concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) +ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods where - decl' = x { tcdSigs = [], tcdMeths = emptyBag } + decl' = decl + { tcdSigs = [], tcdMeths = emptyBag + , tcdATs = [], tcdATDefs = [] + } + + ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + + ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -171,8 +178,8 @@ ppClass dflags x subdocs = out dflags decl' : f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + context = nlHsTyConApp (tcdName decl) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) ppInstance :: DynFlags -> ClsInst -> [String] @@ -369,3 +376,11 @@ escape = concatMap f f '>' = ">" f '&' = "&" f x = [x] + + +semiSeparate :: [SDoc] -> SDoc +semiSeparate = sep . punctuate semi + + +whereWrapper :: [SDoc] -> SDoc +whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space) -- cgit v1.2.3 From fbfd09c8bf12b6991fb0aab24bf01e272f89a131 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 10 Aug 2015 14:38:43 +0200 Subject: Add missing default family equations in Hoogle output. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 0a174fd6..71e7cbc4 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -24,6 +24,7 @@ import Haddock.Utils hiding (out) import Bag import GHC import Outputable +import NameSet import Data.Char import Data.List @@ -169,7 +170,10 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext - ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl + ppTyFams = showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -181,6 +185,14 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods context = nlHsTyConApp (tcdName decl) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) + tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn tfe = SynDecl + { tcdLName = tfe_tycon tfe + , tcdTyVars = tfe_pats tfe + , tcdRhs = tfe_rhs tfe + , tcdFVs = emptyNameSet + } + ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = -- cgit v1.2.3 From 45d72d1d46dda593823bd6aedf860d18d60f3ab2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 10 Aug 2015 16:04:08 +0200 Subject: Improve formatting of class details output in Hoogle backend. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 71e7cbc4..f4f5be90 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -175,6 +175,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) ] + whereWrapper elems = vcat' + [ text "where" <+> lbrace + , nest 4 . vcat . map (<> semi) $ elems + , rbrace + ] + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" @@ -390,9 +396,6 @@ escape = concatMap f f x = [x] -semiSeparate :: [SDoc] -> SDoc -semiSeparate = sep . punctuate semi - - -whereWrapper :: [SDoc] -> SDoc -whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space) +-- | Just like 'vcat' but uses '($+$)' instead of '($$)'. +vcat' :: [SDoc] -> SDoc +vcat' = foldr ($+$) empty -- cgit v1.2.3 From ac10a4ccbe416e8612c6ca49b9f19c3a6f4cf25f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 10 Aug 2015 16:14:18 +0200 Subject: Fix weird-looking Hoogle output for familyless classes. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f4f5be90..f6ad9808 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -160,7 +160,7 @@ ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods where decl' = decl { tcdSigs = [], tcdMeths = emptyBag @@ -170,10 +170,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext - ppTyFams = showSDocUnqual dflags . whereWrapper $ concat - [ map ppr (tcdATs decl) - , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) - ] + ppTyFams + | null $ tcdATs decl = "" + | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + [ map ppr (tcdATs decl) + , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + ] whereWrapper elems = vcat' [ text "where" <+> lbrace -- cgit v1.2.3 From 29c9681c1132eb01fae829ef6848468a2de044e7 Mon Sep 17 00:00:00 2001 From: Eric Seidel Date: Thu, 4 Jun 2015 20:29:56 -0700 Subject: account for changes to ipClass --- haddock-api/src/Haddock/Convert.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 7c9040a9..ce30e1dd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,14 +31,13 @@ import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn -import PrelNames (ipClassName) import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) import TypeRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) +import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) import Var @@ -349,7 +348,7 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | tyConName tc == ipClassName + | tc == ipTyCon , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- cgit v1.2.3 From ad49d1608f406dc83f64f65920f1c6aa2f75403e Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Fri, 19 Dec 2014 08:16:30 +0100 Subject: Follow changes from #6018 --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 29 +++++++++++++++--- haddock-api/src/Haddock/Convert.hs | 42 +++++++++++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 34 +++++++++++++++++---- 3 files changed, 84 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b2b6f904..56b64120 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -230,7 +230,8 @@ ppTyName = ppName Prefix ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = (case info of OpenTypeFamily @@ -245,11 +246,24 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ppFamDeclBinderWithVars summary d <+> - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + (case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + ) <+> + + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) + +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) + + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html @@ -817,6 +831,13 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar name ) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ce30e1dd..43cd0ea2 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,7 +28,7 @@ import DataCon import FamInstEnv import Haddock.Types import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) @@ -39,6 +39,7 @@ import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) +import Util ( filterByList ) import Var @@ -165,7 +166,8 @@ synifyTyCon coax tc | isTypeFamilyTyCon tc = case famTyConFlav_maybe tc of Just rhs -> - let info = case rhs of + let resultVar = famTcResVar tc + info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) @@ -177,21 +179,25 @@ synifyTyCon coax tc AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily Nothing in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) + return (FamDecl (FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + })) Nothing -> Left "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' + FamDecl (FamilyDecl DataFamily (synifyName tc) + (synifyTyVars (tyConTyVars tc)) + (noLoc NoSig) -- always kind '*' + Nothing) -- no injectivity _ -> Left "synifyTyCon: impossible open data type?" | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc @@ -242,6 +248,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLoc . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (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 -- result-type. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2b50ce9a..b8fac887 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -176,6 +176,25 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) + = do { lhs' <- renameL lhs + ; rhs' <- mapM renameL rhs + ; return (L loc (InjectivityAnn lhs' rhs')) } + +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -335,13 +354,16 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily -- cgit v1.2.3 From fea4277692ba68cccc6c9642655289037e4b8979 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Mon, 21 Sep 2015 12:00:47 -0400 Subject: React to refactoring CoAxiom branch lists. --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 43cd0ea2..3fd783aa 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -172,7 +172,7 @@ synifyTyCon coax tc ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) -> return $ ClosedTypeFamily $ Just $ - brListMap (noLoc . synifyAxBranch tc) branches + map (noLoc . synifyAxBranch tc) (fromBranches branches) Nothing -> return $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily $ Just [] -- cgit v1.2.3 From 5890a2d503b3200e9897ce331ad61d808a67fca3 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 25 Jul 2015 17:44:41 -0700 Subject: Track msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ab79fb8d..28f50c35 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,7 +125,9 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = msHsFilePath ms + , ifaceOrigFilename = case msHsFilePath ms of + Just path -> path + Nothing -> "(none)" , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From acfc97fdff76482e90bdd0e93e8982068017d23d Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 26 Sep 2015 16:23:00 +0200 Subject: Create Process: removed PhaseFailed --- haddock-api/src/Haddock.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 72c544e1..5a62f3db 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -118,11 +118,8 @@ handleGhcExceptions = -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure + print (e :: GhcException) + exitFailure ------------------------------------------------------------------------------- -- cgit v1.2.3 From c7a8a8b32c9075873d666f7d0fc8a99828e17344 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 11 Oct 2015 11:31:11 -0700 Subject: s/PackageKey/UnitId/g and s/packageKey/unitId/g Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock.hs | 8 ++++---- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/InterfaceFile.hs | 12 ++++++------ haddock-api/src/Haddock/ModuleTree.hs | 6 +++--- haddock-api/src/Haddock/Types.hs | 2 +- 8 files changed, 22 insertions(+), 22 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5a62f3db..72ec21c8 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -222,7 +222,7 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] + srcMap = Map.fromList [ (ifUnitId if_, x) | ((_, Just x), if_) <- pkgs ] render dflags flags qual interfaces installedIfaces srcMap @@ -247,8 +247,8 @@ render dflags flags qual ifaces installedIfaces srcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod - pkgStr = Just (packageKeyString pkgKey) + pkgKey = moduleUnitId pkgMod + pkgStr = Just (unitIdString pkgKey) (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -314,7 +314,7 @@ modulePackageInfo dflags flags modu = (fromMaybe (packageName pkg) (optPackageName flags), fromMaybe (packageVersion pkg) (optPackageVersion flags)) where - pkg = getPackageDetails dflags (modulePackageKey modu) + pkg = getPackageDetails dflags (moduleUnitId modu) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 6ef1e863..b2710703 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -305,7 +305,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index b2c60534..f1f109c5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -225,7 +225,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey origMod + origPkg = moduleUnitId origMod -- Name must be documented, otherwise we wouldn't get here Documented n mdl = head names diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 28f50c35..75702b50 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -160,7 +160,7 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageKey $ + (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -168,13 +168,13 @@ mkAliasMap dflags mRenamedSource = -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageKey -> ModuleName -> Module + DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainPackageKey mdlName + [] -> Module.mkModule Module.mainUnitId mdlName ------------------------------------------------------------------------------- @@ -692,8 +692,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageKey expMod - packageKey = modulePackageKey thisMod + m = mkModule unitId expMod + unitId = moduleUnitId thisMod -- Note [1]: diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e8db3cfb..4b66348c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifUnitId, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -52,11 +52,11 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifUnitId :: InterfaceFile -> UnitId +ifUnitId if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> moduleUnitId $ instMod iface binaryInterfaceMagic :: Word32 @@ -310,7 +310,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName) +type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName @@ -340,7 +340,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) + put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2f731214..e6cf8201 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) +import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) @@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 847320a7..5737c77c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -52,7 +52,7 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath +type SrcMap = Map UnitId FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources -- cgit v1.2.3 From 85b7ed6147c18611b5ef6b606f157086a8203e7d Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Fri, 16 Oct 2015 16:26:42 +0100 Subject: Roughly fix up haddock for DuplicateRecordFields changes This compiles, but will probably need more work to produce good documentation when the DuplicateRecordFields extension is used. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 11 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++++---- haddock-api/src/Haddock/Convert.hs | 8 +++++--- haddock-api/src/Haddock/GhcUtils.hs | 3 ++- haddock-api/src/Haddock/Interface/Create.hs | 17 ++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 8 ++++++-- haddock-api/src/Haddock/Types.hs | 4 ++-- haddock-api/src/Haddock/Utils.hs | 5 ++++- 9 files changed, 45 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index fe656a4b..55075e20 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -190,8 +190,8 @@ ppCtor dflags dat subdocs con 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) (cd_fld_names r)) ++ - [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(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]] | r <- map unLoc recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b8558f4f..68149b41 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -24,9 +24,10 @@ import qualified Pretty import GHC import OccName import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) +import RdrName ( rdrNameOcc, mkRdrUnqual ) import FastString ( unpackFS, unpackLitString, zString ) import Outputable ( panic) +import PrelNames ( mkUnboundName ) import qualified Data.Map as Map import System.Directory @@ -686,12 +687,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . 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 (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -900,7 +901,9 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC :: HsType DocName + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 56b64120..f94daabf 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -38,6 +38,8 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc, mkRdrUnqual ) +import PrelNames ( mkUnboundName ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -741,18 +743,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, 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 (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -874,7 +876,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3fd783aa..f0fc108b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -30,6 +30,7 @@ import Haddock.Types import HsSyn import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name +import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) @@ -293,9 +294,10 @@ synifyDataCon use_gadt_syntax dc = bang' -> noLoc $ HsBangTy bang' tySyn) arg_tys (dataConSrcBangs dc) - field_tys = zipWith (\field synTy -> noLoc $ ConDeclField - [synifyName field] synTy Nothing) - (dataConFieldLabels dc) linear_tys + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLoc $ + ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5caefa77..aa9a1c32 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -189,7 +189,8 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) + RecCon fields -> map (selectorFieldOcc . unL) $ + concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 75702b50..8f3b9f9a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -331,15 +331,16 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] + dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- con_names c ] - fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , n <- ns ] + , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -501,7 +502,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEThingWith (L _ t) _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ @@ -790,7 +791,7 @@ extractDecl name mdl decl , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) @@ -821,11 +822,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] + matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b8fac887..033246a8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -273,7 +273,7 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) @@ -411,11 +411,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do - names' <- mapM renameL names + names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') +renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc (L l (FieldOcc lbl sel)) = do + sel' <- rename sel + return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5737c77c..33ab9592 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -281,7 +281,6 @@ data DocName -- documentation, as far as Haddock knows. deriving Eq - instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -562,8 +561,9 @@ instance Monad ErrMsgGhc where type instance PostRn DocName NameSet = PlaceHolder type instance PostRn DocName Fixity = PlaceHolder type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = PlaceHolder +type instance PostRn DocName Name = DocName type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..c2e1b09a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,6 +63,7 @@ import Haddock.GhcUtils import GHC import Name +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns + field_avail :: LConDeclField Name -> Bool + field_avail (L _ (ConDeclField fs _ _)) + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3 From a394ee884befd8cc8ba31a6071afaec7cca14e7c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 26 Oct 2015 12:52:36 +0000 Subject: Track wip/spj-wildcard-refactor on main repo --- haddock-api/src/Haddock/Backends/Hoogle.hs | 33 ++++++---------- haddock-api/src/Haddock/Convert.hs | 33 +++++++++------- haddock-api/src/Haddock/GhcUtils.hs | 12 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 61 ++++++++++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 2 +- 5 files changed, 80 insertions(+), 61 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..8664db27 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + 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) @@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -120,22 +113,19 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) +ppSig dflags (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where prettyNames = intercalate ", " $ map (out dflags) names - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x + typ = unL (hsSigType sig) ppSig _ _ = [] @@ -144,12 +134,13 @@ ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs + addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) + f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) + f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty + f ty = HsQualTy (reL [context]) ty context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) @@ -194,10 +185,10 @@ ppCtor dflags dat subdocs con [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) name = out dflags $ map unL $ con_names con resType = case con_res con of diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f0fc108b..d74d528e 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -96,7 +96,7 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc)) []) + (synifyType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps @@ -118,10 +118,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name - , tfe_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs - , hswb_wcs = [] } + , tfe_pats = HsIB { hsib_body = typats + , hsib_kvs = map tyVarName kvs + , hsib_tvs = map tyVarName tvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -310,8 +309,14 @@ synifyDataCon use_gadt_syntax dc = else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care - qvars ctx hat hs_res_ty Nothing + \hat -> return $ noLoc $ + ConDecl { con_names = [name] + , con_explicit = False -- we don't know nor care + , con_qvars = qvars + , con_cxt = ctx + , con_details = hat + , con_res = hs_res_ty + , con_doc = Nothing } -- we don't want any "deprecated GADT syntax" warnings! False @@ -327,7 +332,7 @@ synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars :: [TyVar] -> LHsQTyVars Name synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where @@ -393,15 +398,13 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - mkHsForAllTy forallPlicitness = - noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) + , hst_body = noLoc (synify WithinType tau) } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> mkHsForAllTy Explicit - ImplicitizeForAll -> mkHsForAllTy Implicit + WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + , hst_body = noLoc sPhi } + ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index aa9a1c32..49d6a420 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -69,7 +69,7 @@ getMainDeclBinder _ = [] -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances @@ -92,10 +92,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty nwcs) = +filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty nwcs) + filtered -> Just (TypeSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -106,8 +106,8 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _ _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns @@ -199,7 +199,7 @@ instance Parent (TyClDecl Name) 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 = [] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 033246a8..318a88c0 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLSigType = renameWc renameLType + +renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLWcSigType = renameImplicit renameLSigType + renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl extra tyvars lcontext ltype -> do + HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- renameLTyVarBndrs tyvars + ltype' <- renameLType ltype + return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + + HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl extra tyvars' lcontext' ltype') + return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype @@ -252,7 +262,7 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } @@ -423,16 +433,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype _ -> do + TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLType ltype - return (TypeSig lnames' ltype' PlaceHolder) + ltype' <- renameLWcSigType ltype + return (TypeSig lnames' ltype') PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - lty' <- renameLType lty + lty' <- renameLSigType lty return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames @@ -445,11 +455,11 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -484,33 +494,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + = do { tc' <- renameL tc + ; tvs' <- renameLTyVarBndrs tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing) + -> HsImplicitBndrs Name in_thing + -> RnM (HsImplicitBndrs DocName out_thing) +renameImplicit rn_thing (HsIB { hsib_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsIB { hsib_body = thing' + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + +renameWc :: (in_thing -> RnM out_thing) + -> HsWildcardBndrs Name in_thing + -> RnM (HsWildcardBndrs DocName out_thing) +renameWc rn_thing (HsWC { hswc_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsWC { hswc_body = thing' + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index c2e1b09a..3964c86a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name +emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -- cgit v1.2.3 From 18de4f2f992d3ed41eb83cb073e63304f0271dca Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 14:24:56 +0000 Subject: Track change to PatSyn.patSynSig --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f0fc108b..6f0684dc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -99,7 +99,7 @@ tyThingToLHsDecl t = case t of (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps qtvs = univ_tvs ++ ex_tvs ty = mkFunTys arg_tys res_ty in allOK . SigD $ PatSynSig (synifyName ps) -- cgit v1.2.3 From ec20bd15e724d580a01d9fad98791bb53db5e57c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 17:34:18 +0000 Subject: Follow changes to HsTYpe Not yet complete (but on a wip/ branch) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 31 +++++++----------- haddock-api/src/Haddock/Convert.hs | 46 ++++++++++++++------------ haddock-api/src/Haddock/Interface/Create.hs | 48 ++++++++------------------- haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++--------------- haddock-api/src/Haddock/Utils.hs | 29 ++++++++++++++++ 5 files changed, 103 insertions(+), 102 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 8664db27..b7dfad64 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -113,38 +113,29 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (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 _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = unL (hsSigType sig) +ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig) ppSig _ _ = [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String] +pp_sig dflags names (L _ typ) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [String] ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) - where - addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - - f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) - f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty - f ty = HsQualTy (reL [context]) ty - - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) - + concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x) + where + add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = [dropComment $ out dflags x] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d74d528e..952650c1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -96,17 +96,10 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps - qtvs = univ_tvs ++ ex_tvs - ty = mkFunTys arg_tys res_ty - in allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -316,16 +309,16 @@ synifyDataCon use_gadt_syntax dc = , con_cxt = ctx , con_details = hat , con_res = hs_res_ty - , con_doc = Nothing } + , con_doc = Nothing -- we don't want any "deprecated GADT syntax" warnings! - False + , con_old_rec = False } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] +synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name @@ -337,12 +330,14 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv + +synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -360,6 +355,15 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +-- The empty binders is a bit suspicious; +-- what if the type has free variables? +synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) + +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +-- Ditto (see synifySigType) +synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) + synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) @@ -398,11 +402,11 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) - , hst_body = noLoc (synify WithinType tau) } + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8f3b9f9a..d53e7351 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -347,15 +347,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty _) -> docs (unLoc ty) - SigD (PatSynSig _ _ req prov ty) -> - let allTys = ty : concat [ unLoc req, unLoc prov ] - in F.foldMap (docs . unLoc) allTys - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) + SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) + ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) + 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 @@ -728,8 +727,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) @@ -773,17 +772,17 @@ extractDecl name mdl decl case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity + isTypeLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 + [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) + in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } + , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> @@ -797,24 +796,6 @@ extractDecl name mdl decl [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc - - -extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of - L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) - where - lctxt = noLoc . ctxt - ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name @@ -823,7 +804,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] @@ -833,7 +814,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) = | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 318a88c0..f95e527e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,11 +170,11 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType -renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLSigType = renameWc renameLType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType = renameImplicit renameLType -renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLWcSigType = renameImplicit renameLSigType +renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType = renameImplicit (renameWc renameLType) renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -205,11 +205,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) - HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do + HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) @@ -262,10 +262,10 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -330,13 +330,13 @@ renameTyClD d = case d of SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) @@ -344,7 +344,7 @@ renameTyClD d = case d of , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats @@ -368,7 +368,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' @@ -397,7 +397,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype @@ -435,15 +435,12 @@ renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLWcSigType ltype + ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') - PatSynSig lname (flag, qtvs) lreq lprov lty -> do + PatSynSig lname sig_ty -> do lname' <- renameL lname - qtvs' <- renameLTyVarBndrs qtvs - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - lty' <- renameLSigType lty - return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + sig_ty' <- renameLSigType sig_ty + return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) @@ -478,7 +475,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode @@ -505,7 +502,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' @@ -526,15 +523,15 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildcardBndrs Name in_thing - -> RnM (HsWildcardBndrs DocName out_thing) + -> HsWildCardBndrs Name in_thing + -> RnM (HsWildCardBndrs DocName out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3964c86a..6a499f64 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -16,6 +16,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, + mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) + +addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +-- Add the class context to a class-op signature +addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) + = L pos (TypeSig 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 }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { 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 }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar (hsLTyVarName tv)) + | tv <- hsQTvBndrs tvs ] + -------------------------------------------------------------------------------- -- * Making abstract declarations -------------------------------------------------------------------------------- -- cgit v1.2.3 From 174f23631a0a8de7dc0f3cd67c393a5ca88c4a2b Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 23 Sep 2015 18:43:18 +0200 Subject: Account for Typeable changes The treatment of type families changed. --- haddock-api/src/Haddock/Convert.hs | 69 ++++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6f0684dc..4cb42597 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -141,7 +141,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon coax tc +synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc @@ -164,42 +164,37 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc - = case famTyConFlav_maybe tc of - Just rhs -> - let resultVar = famTcResVar tc - info = case rhs of - OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon mb -> case mb of - Just (CoAxiom { co_ax_branches = branches }) - -> return $ ClosedTypeFamily $ Just $ - map (noLoc . synifyAxBranch tc) (fromBranches branches) - Nothing -> return $ ClosedTypeFamily $ Just [] - BuiltInSynFamTyCon {} - -> return $ ClosedTypeFamily $ Just [] - AbstractClosedSynFamilyTyCon {} - -> return $ ClosedTypeFamily Nothing - in info >>= \i -> - return (FamDecl (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) - , fdInjectivityAnn = - synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) - })) - Nothing -> Left "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) - (synifyTyVars (tyConTyVars tc)) - (noLoc NoSig) -- always kind '*' - Nothing) -- no injectivity - _ -> Left "synifyTyCon: impossible open data type?" +synifyTyCon _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = famTcResVar tc + mkFamDecl i = return $ FamDecl $ + FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + } + +synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) -- cgit v1.2.3 From 8358cd222cc5a2d9f971691fe62e7e2c352d7c9b Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 30 Oct 2015 13:03:51 +0000 Subject: Work on updating Haddock to wip/spj-wildard-recactor Still incomplete --- haddock-api/src/Haddock/Backends/LaTeX.hs | 143 ++++++++++--------------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 17 ++- haddock-api/src/Haddock/Utils.hs | 2 +- 3 files changed, 63 insertions(+), 99 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 68149b41..dfeb1428 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -213,9 +213,9 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -250,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _ _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -293,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + 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 lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -311,8 +312,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -329,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -340,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -352,29 +355,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of - (Nothing, Nothing) -> empty - (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -394,22 +385,14 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Qualified e a lctxt ltype) - = do_args n leader (HsForAllTy Implicit e a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args _n leader (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 @@ -424,12 +407,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -478,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -521,8 +504,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -613,21 +596,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -661,13 +643,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -675,7 +657,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs 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 @@ -791,9 +778,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode @@ -879,34 +863,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Bool -> LaTeX -ppLTyVarBndrs expl tvs unicode - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - | otherwise = empty - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where - anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt + 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 name) _ = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f94daabf..7f1d7d07 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -50,8 +50,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + SigD (PatSynSig lname ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -74,23 +74,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = pp_typ = ppType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppBinder summary occname + , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode (hsSigType ty) ] cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 6a499f64..f7a32dd3 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -132,7 +132,7 @@ mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name -- Add the class context to a class-op signature -addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) +addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where -- cgit v1.2.3 From 987b5062482e20a032fb6358e655265b0b7a3cd2 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 31 Oct 2015 11:01:45 +0100 Subject: Relax upper bound on `base` to allow base-4.9 --- haddock-api/haddock-api.cabal | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b2199c68..dc3e8c69 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -36,7 +36,7 @@ library Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , filepath , directory diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b0f886cd..d21b851e 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,7 +21,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , transformers , deepseq diff --git a/haddock.cabal b/haddock.cabal index 3b6002f1..56e62e60 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -45,7 +45,7 @@ executable haddock ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE -- cgit v1.2.3 From b2d4b230c2446d241fd8730cd158e4fe6b7305df Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Sat, 31 Oct 2015 19:08:13 +0000 Subject: More adaption to wildcard-refactor --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 162 +++++++++++++------------ 3 files changed, 85 insertions(+), 81 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index dfeb1428..3514f74e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -384,7 +384,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index b2710703..31757eeb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -584,7 +584,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _) _) -> + SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7f1d7d07..c523d610 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -45,13 +45,14 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -61,20 +62,20 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> LHsSigType DocName + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual @@ -83,18 +84,11 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unico +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppDocBinder name + , ppBinder summary occname , dcolon unicode - , ppLType unicode (hsSigType ty) + , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of - (Nothing, Nothing) -> noHtml - (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -128,22 +122,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + 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) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs 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 $ @@ -171,20 +172,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs - -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -199,7 +199,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvBndrs ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -285,7 +286,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) @@ -358,10 +359,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc - -ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -392,7 +389,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -425,8 +422,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- sigs + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig 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 @@ -470,8 +468,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -484,12 +483,12 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -660,23 +659,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L loc con) + = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of @@ -706,12 +705,19 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + <+> ppLType unicode qual (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) <+> fixity + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + | otherwise = ty + fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual occ = map (nameOccName . getName . unLoc) $ con_names con @@ -844,38 +850,36 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAllCon :: Bool -> LHsQTyVars DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html ppForAllCon expl tvs cxt unicode qual = forall_part <+> ppLContext cxt unicode qual where forall_part = ppLTyVarBndrs expl tvs unicode qual -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Unicode -> Qualification - -> Html -ppLTyVarBndrs expl tvs unicode _qual - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - | otherwise = noHtml +ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html +ppLTyVarBndrs show_forall tvs unicode _qual + | show_forall + , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode + | otherwise = noHtml where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + tv_bndrs = hsQTvBndrs tvs +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ -- cgit v1.2.3 From 7f4519f0bb2a490fd9c1b42d37ae4f14390551b4 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 27 Oct 2015 16:12:50 +0200 Subject: Matching change GHC #11017 BooleanFormula located --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 9 +++++---- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +++- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f94daabf..8996fc87 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -486,9 +486,9 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of + minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] -> noHtml @@ -504,9 +504,10 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances instances nm unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4cb42597..9cc9e115 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -78,7 +78,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 mempty . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8f3b9f9a..6a9c8cd4 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -557,7 +557,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -749,7 +749,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 033246a8..131082cd 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -437,7 +437,9 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig src s -> MinimalSig src <$> traverse renameL s + MinimalSig src (L l s) -> do + s' <- traverse renameL s + return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3 From 52c963e0b19783c4ca59cd0e8cfe1366dbfa1624 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Sun, 1 Nov 2015 12:08:58 +0000 Subject: Change for IEThingWith --- haddock-api/src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6a9c8cd4..5b9532e6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -502,7 +502,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _) = declWith t + lookupExport (IEThingWith (L _ t) _ _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ -- cgit v1.2.3 From 83a9e9d2c7f0debec9d56e8b3b7cc8a8eb73361e Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 11 Nov 2015 11:35:51 +0100 Subject: Eliminate support for deprecated GADT syntax Follows from GHC D1460. --- haddock-api/src/Haddock/Convert.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 9cc9e115..a61e3696 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -307,8 +307,6 @@ synifyDataCon use_gadt_syntax dc = in hs_arg_tys >>= \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care qvars ctx hat hs_res_ty Nothing - -- we don't want any "deprecated GADT syntax" warnings! - False synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -- cgit v1.2.3 From e763c004c8eb067ed0ef510fda9cb4ab102ea6ae Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Fri, 13 Nov 2015 21:56:18 -0800 Subject: Undo msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5b9532e6..9b8bbe50 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,9 +125,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = case msHsFilePath ms of - Just path -> path - Nothing -> "(none)" + , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From c122a762c7839704644221a251cbe5ad3254f836 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 18 Nov 2015 11:32:54 +0000 Subject: Wibbles to Haddock --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index dca16408..b0a4f503 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -482,8 +482,8 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method -- cgit v1.2.3 From fcd1bb7177a800f6f56a623c2468fc46a59c527b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 21 Nov 2015 21:16:12 +0200 Subject: Update to match GHC wip/T11019 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 6 +++--- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 10 +++++----- haddock-api/src/Haddock/Types.hs | 13 +++++++------ 7 files changed, 27 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..68896d72 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -152,7 +152,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + (map (reL . HsTyVar . reL . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) ppInstance :: DynFlags -> ClsInst -> [String] @@ -201,7 +201,7 @@ ppCtor dflags dat subdocs con name = out dflags $ map unL $ con_names con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ + ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT _ x -> x diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 68149b41..c4468c9c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -902,14 +902,14 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] where anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -947,7 +947,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8996fc87..328684f3 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -835,7 +835,7 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html -ppHsTyVarBndr _ qual (UserTyVar name ) = +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> @@ -877,19 +877,19 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ +ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -928,7 +928,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a61e3696..ff34d271 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -326,7 +326,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs where (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv @@ -349,7 +349,7 @@ data SynifyTypeState synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -374,7 +374,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) + (noLoc $ HsTyVar $ noLoc (getName tc)) (map (synifyType WithinType) tys) synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9b8bbe50..349356d6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -800,7 +800,7 @@ extractDecl name mdl decl toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc +toTypeNoLoc = noLoc . HsTyVar extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name @@ -829,7 +829,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 131082cd..f9edb574 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -204,7 +204,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsForAllTy expl extra tyvars' lcontext' ltype') - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -259,9 +259,9 @@ renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -273,8 +273,8 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name -renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 33ab9592..43671de3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -558,12 +558,13 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = DocName +type instance PostRn DocName (Located Name) = Located DocName +type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder -- cgit v1.2.3 From 42b2cfc595f1ee62d1c1b8513c5df1d92709c06a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 23 Nov 2015 17:17:18 +0000 Subject: Wibble --- haddock-api/src/Haddock/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index f7a32dd3..658007ba 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -150,7 +150,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (hsLTyVarName tv)) + = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) | tv <- hsQTvBndrs tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3 From a6deefad581cbeb62048826bc1d626c41a0dd56c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 5 Dec 2015 00:29:55 +0100 Subject: Canonicalise Monad instances --- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Types.hs | 10 +++++----- .../attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs | 6 +++--- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index eda5f1bf..f2f93966 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -91,13 +91,13 @@ newtype RnM a = instance Monad RnM where (>>=) = thenRn - return = returnRn + return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where - pure = return + pure = returnRn (<*>) = ap returnRn :: a -> RnM a diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 43671de3..f667b52c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -492,11 +492,11 @@ instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where - pure = return - (<*>) = ap + pure a = Writer (a, []) + (<*>) = ap instance Monad ErrMsgM where - return a = Writer (a, []) + return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a) @@ -545,11 +545,11 @@ instance Functor ErrMsgGhc where fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where - pure = return + pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) + return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs index 6719e09a..9c7994e9 100644 --- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs @@ -126,7 +126,7 @@ instance Monad (Parser i) where where msg = "Failed reading: " ++ err {-# INLINE fail #-} - return v = Parser $ \t pos more _lose succ -> succ t pos more v + return = pure {-# INLINE return #-} m >>= k = Parser $ \t !pos more lose succ -> @@ -158,7 +158,7 @@ apP d e = do {-# INLINE apP #-} instance Applicative (Parser i) where - pure = return + pure v = Parser $ \t pos more _lose succ -> succ t pos more v {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} @@ -166,7 +166,7 @@ instance Applicative (Parser i) where -- These definitions are equal to the defaults, but this -- way the optimizer doesn't have to work so hard to figure -- that out. - (*>) = (>>) + m *> k = m >>= \_ -> k {-# INLINE (*>) #-} x <* y = x >>= \a -> y >> return a {-# INLINE (<*) #-} -- cgit v1.2.3 From 222954753de7a8a3708baff1d75a4b7c3a675f4b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 17:33:52 +0200 Subject: Matching changes for #11028 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 71 ++++++++++++++- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 ++++++++----------------- haddock-api/src/Haddock/Convert.hs | 24 ++--- haddock-api/src/Haddock/GhcUtils.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 13 +-- haddock-api/src/Haddock/Interface/Rename.hs | 28 +++--- haddock-api/src/Haddock/Utils.hs | 20 ++++- 8 files changed, 176 insertions(+), 121 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index bc5588af..54dfb193 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -166,8 +166,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] @@ -180,12 +181,18 @@ ppCtor dflags dat subdocs con apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) - name = out dflags $ map unL $ con_names con + name = out dflags $ map unL $ getConNames con - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ + resType = apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] + + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4aec7917..223006f3 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -575,14 +575,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -607,6 +607,71 @@ ppConstrHdr forall tvs ctxt unicode False -> empty +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> 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 + + 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 []) (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) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + 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. + mbDoc = case getConNames con of + [] -> 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) = @@ -670,7 +735,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1aa4d954..d49d0949 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -539,11 +539,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -557,7 +557,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -573,7 +575,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -582,15 +586,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] instancesBit = ppInstances instances docname unicode qual @@ -606,8 +608,8 @@ 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 DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +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) args), noHtml, noHtml) @@ -620,28 +622,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -651,12 +640,11 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax @@ -675,11 +663,11 @@ ppConstrHdr forall_ tvs ctxt unicode qual ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L loc con) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -693,35 +681,25 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> ppLType unicode qual (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + <+> ppLType unicode qual ty <+> fixity - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) - | otherwise = ty - fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -731,15 +709,13 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con + tyVars = tyvarNames (fromMaybe (HsQTvs 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 $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification @@ -848,24 +824,6 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAllCon :: Bool -> LHsQTyVars DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html -ppLTyVarBndrs show_forall tvs unicode _qual - | show_forall - , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode - | otherwise = noHtml - where - tv_bndrs = hsQTvBndrs tvs - ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot @@ -898,7 +856,9 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur + -- un ConDeclGADT, but is + -- output elsewhere ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 49c471a4..8983cc77 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -292,19 +292,21 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT noSrcSpan (synifyType WithinType res_ty) - else ResTyH98 + gadt_ty = HsIB [] [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return $ noLoc $ - ConDecl { con_names = [name] - , con_explicit = False -- we don't know nor care - , con_qvars = qvars - , con_cxt = ctx - , con_details = hat - , con_res = hs_res_ty - , con_doc = Nothing } + \hat -> + if use_gadt_syntax + then return $ noLoc $ + ConDeclGADT { con_names = [name] + , con_type = gadt_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 } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 49d6a420..ab4d6c78 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -188,14 +188,14 @@ class Parent a where instance Parent (ConDecl Name) where children con = - case con_details con of + case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d - | isDataDecl d = map unL $ concatMap (con_names . unL) + | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ @@ -209,7 +209,7 @@ family = getName &&& children familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) +familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index da59c5fa..30b32963 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -47,6 +47,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -334,9 +335,9 @@ subordinates instMap decl = case decl of where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] + | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] @@ -785,7 +786,8 @@ extractDecl name mdl decl SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -800,7 +802,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of + 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))))) _ -> extractRecSel nm mdl t tvs rest @@ -809,7 +811,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) = matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty + -- | ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = hsib_body $ con_type con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f2f93966..0b975687 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -393,17 +393,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -415,9 +414,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 658007ba..45deca9c 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -180,18 +180,32 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = - case con_details d of + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (h98d { con_details = 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 Name + c' = ConDeclH98 + { con_name = head (con_names c) + , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_cxt = Just cxt + , con_details = details + , con_doc = con_doc c + } + field_avail :: LConDeclField Name -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs -- cgit v1.2.3 From f4ef2548954bedf26674adc7a06574e718898d19 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 19:45:33 +0200 Subject: Placeholder for record style GADT declaration A GADT Declaration is now presented as CmmCondBranch :: {..} -> CmmNode O C cml_pred :: CmmExpr cml_true, cml_false :: !Label cml_likely :: Maybe Bool for CmmCondBranch :: { -- conditional branch cml_pred :: CmmExpr, cml_true, cml_false :: ULabel, cml_likely :: Maybe Bool -- likely result of the conditional, -- if known } -> CmmNode O C --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d49d0949..4983aadd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -694,6 +694,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT <+> ppLType unicode qual ty <+> fixity @@ -856,9 +857,10 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur - -- un ConDeclGADT, but is - -- output elsewhere +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 _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -- cgit v1.2.3 From 0fc8cfd532f5dfd12b5504f44a2b3c9fb659cd87 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 8 Dec 2015 23:54:34 -0500 Subject: Update for type=kinds --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 ++-- haddock-api/src/Haddock/Convert.hs | 43 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 24 ++++++++---- haddock-api/src/Haddock/Interface/Rename.hs | 12 +++--- haddock-api/src/Haddock/Utils.hs | 8 ++-- 7 files changed, 60 insertions(+), 46 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 54dfb193..e73192ed 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -184,7 +184,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} name = out dflags $ map unL $ getConNames con resType = apps $ map (reL . HsTyVar . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 223006f3..e9cc3f83 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -412,7 +412,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName) tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -723,7 +723,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + 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) @@ -955,7 +955,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -965,7 +964,7 @@ 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 +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -985,6 +984,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4983aadd..0b5a3356 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html] ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvBndrs ltyvars)) + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -864,7 +864,7 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ @@ -874,7 +874,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 8983cc77..2e28b0dd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,19 +28,19 @@ import DataCon import FamInstEnv import Haddock.Types import HsSyn -import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) -import Util ( filterByList ) +import Util ( filterByList, filterOut ) import Var @@ -109,11 +109,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats - , hsib_kvs = map tyVarName kvs - , hsib_tvs = map tyVarName tvs } + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -141,8 +139,8 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -180,11 +178,12 @@ synifyTyCon _coax tc , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) + synifyFamilyResultSig resultVar tyConResKind , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) (familyTyConInjectivityInfo tc) } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc @@ -292,7 +291,7 @@ 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) + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> @@ -321,10 +320,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } - where - (kvs, tvs) = partition isKindVar ktvs +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv @@ -379,19 +376,21 @@ synifyType _ (TyConApp tc tys) , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) (noLoc $ HsTyVar $ noLoc (getName tc)) - (map (synifyType WithinType) tys) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +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 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 @@ -406,6 +405,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -421,7 +422,7 @@ synifyInstHead (_, preds, cls, types) = , map (unLoc . synifyType WithinType) ts , ClassInst $ map (unLoc . synifyType WithinType) preds ) - where (ks,ts) = break (not . isKind) types + where (ks,ts) = partitionInvisibles (classTyCon cls) id types -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) @@ -434,4 +435,4 @@ synifyFamInst fi opaque = synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, map (unLoc . synifyType WithinType) ts , f') - where (ks,ts) = break (not . isKind) $ fi_tys fi + where (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 080de6ff..86a9957c 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -41,7 +42,7 @@ import PrelNames import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -146,18 +147,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -207,9 +216,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0b975687..845cb909 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -234,11 +234,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -254,18 +254,18 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -529,7 +529,7 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } + , hsib_vars = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 45deca9c..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) - | tv <- hsQTvBndrs tvs ] + | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- * Making abstract declarations @@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] c' :: ConDecl Name c' = ConDeclH98 { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } , con_cxt = Just cxt , con_details = details , con_doc = con_doc c @@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3 From 33e89b2b4719f0dd1cd416c7d20d610be504910c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Mon, 22 Dec 2014 17:51:52 +0100 Subject: Bump versions for ghc-7.11 --- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index d5762ce8..4f4218c9 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -78,7 +78,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711) +#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 713) binaryInterfaceVersion = 27 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock.cabal b/haddock.cabal index 71b78347..6b5a8044 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -59,7 +59,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.9 && < 7.12, + ghc >= 7.11 && < 7.13, bytestring, transformers -- cgit v1.2.3 From 7e49f55580ffb701944603983b41873649bb35f6 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 23 Dec 2014 15:22:56 +0000 Subject: Eliminate instanceHead' in favour of GHC's instanceSig This is made possible by the elimination of "silent superclass parameters" in GHC --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index e2fd24ee..21569374 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -82,7 +82,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = , let opaque = isTypeHidden expInfo (fi_rhs i) ] cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] @@ -131,20 +131,6 @@ instLookup f name iface ifaceMap instIfaceMap = iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's 'instanceHead' but drops "silent" arguments. -instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) -instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) - where - dfun = is_dfun ispec - (tvs, cls, tys) = instanceHead ispec - (_, theta, _) = tcSplitSigmaTy (idType dfun) - --- | Drop "silent" arguments. See GHC Note [Silent superclass --- arguments]. -dropSilentArgs :: DFunId -> ThetaType -> ThetaType -dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta - - -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -- cgit v1.2.3 From 85ea110309c23509817a26aad7dd6d072f9f732b Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 6 Jan 2015 16:37:47 +0000 Subject: Remove redundant constraints from haddock, discovered by -fwarn-redundant-constraints --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 1bb04ed3..afb5111e 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -239,6 +239,6 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) -------------------------------------------------------------------------------- -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a withTempDir dir = gbracket_ (liftIO $ createDirectory dir) (liftIO $ removeDirectoryRecursive dir) -- cgit v1.2.3 From 45ca97d6b02d92924c0aa2a25ba7a940c70cf9aa Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 10 Feb 2015 12:10:33 +0000 Subject: Track changes in HsSyn for quasi-quotes --- haddock-api/src/Haddock/Backends/LaTeX.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - haddock-api/src/Haddock/Interface/Rename.hs | 4 ---- 3 files changed, 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 24779a94..fde12350 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -913,7 +913,6 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e536ae4b..3ac443a4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -968,7 +968,6 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 146a7c0b..9d848122 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -230,14 +230,10 @@ renameType t = case t of HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildcardTy -> pure HsWildcardTy HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a -renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) -renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c - renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs -- cgit v1.2.3 From 20e56de6316d6e251975aa5a4ce39d48e5bf6798 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 1 May 2015 09:36:47 +0100 Subject: Track change in API of TyCon --- haddock-api/src/Haddock/Convert.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index c9664652..2bd111d6 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -339,8 +339,9 @@ synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. - | isTupleTyCon tc, tyConArity tc == length tys = - noLoc $ HsTupleTy (case tupleTyConSort tc of + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = noLoc $ HsTupleTy (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) -- cgit v1.2.3 From b731a89153266e29f160a76f3ebaaa3a4621f199 Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Mon, 4 May 2015 15:32:59 +0100 Subject: Track API changes to support empty closed type familes --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Convert.hs | 16 ++++++++++------ haddock-api/src/Haddock/Interface/Rename.hs | 2 +- 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3ac443a4..651060c1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -287,9 +287,9 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise = ppInstances links (OriginFamily docname) instances splice unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 2bd111d6..dd577319 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -132,7 +132,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch , tfid_fvs = placeHolderNamesTc })) - | Just ax' <- isClosedSynFamilyTyCon_maybe tc + | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error = synifyTyCon (Just ax) tc >>= return . TyClD @@ -169,11 +169,15 @@ synifyTyCon coax tc Just rhs -> let info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - return $ ClosedTypeFamily - (brListMap (noLoc . synifyAxBranch tc) branches) - BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily [] - AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily [] + ClosedSynFamilyTyCon mb -> case mb of + Just (CoAxiom { co_ax_branches = branches }) + -> return $ ClosedTypeFamily $ Just $ + brListMap (noLoc . synifyAxBranch tc) branches + Nothing -> return $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> return $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> return $ ClosedTypeFamily Nothing in info >>= \i -> return (FamDecl (FamilyDecl { fdInfo = i diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 9d848122..110c9a42 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -362,7 +362,7 @@ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM renameLTyFamInstEqn eqns + = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) -- cgit v1.2.3 From 53ae59ff35fefacff28823f5b7c9e86535cbf024 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 13 May 2015 12:04:21 +0100 Subject: Track the new location of setRdrNameSpace --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 14826eaa..0f6add36 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -28,7 +28,8 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import Outputable (showPpr) +import RdrHsSyn ( setRdrNameSpace ) +import Outputable ( showPpr ) import RdrName import RnEnv (dataTcOccs) -- cgit v1.2.3 From 75a23ec042888ba5387ad653b74fe170a6721784 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 25 May 2015 17:14:01 +0200 Subject: ApiAnnotations : strings in warnings do not return SourceText The strings used in a WARNING pragma are captured via strings :: { Located ([AddAnn],[Located FastString]) } : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) } .. The STRING token has a method getSTRINGs that returns the original source text for a string. A warning of the form {-# WARNING Logic , mkSolver , mkSimpleSolver , mkSolverForLogic , solverSetParams , solverPush , solverPop , solverReset , solverGetNumScopes , solverAssertCnstr , solverAssertAndTrack , solverCheck , solverCheckAndGetModel , solverGetReasonUnknown "New Z3 API support is still incomplete and fragile: \ \you may experience segmentation faults!" #-} returns the concatenated warning string rather than the original source. --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 0599151e..8b4605a7 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -164,7 +164,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - ideclPkgQual impDecl) + fmap snd $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -200,8 +200,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From bf4041f408623536bd9684586f5736d5ca7f12dd Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 8 Jun 2015 23:47:28 -0500 Subject: Update after wild card renaming refactoring in D613 Summary: * Move `Post*` type instances to `Haddock.Types` as other modules than `Haddock.Interface.Rename` will rely on these type instances. * Update after wild card renaming refactoring in D613. Reviewers: simonpj, austin Reviewed By: austin Differential Revision: https://phabricator.haskell.org/D954 GHC Trac Issues: #10098 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 12 +++++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 +++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 7 +++++-- haddock-api/src/Haddock/Types.hs | 16 ++++++++++++++++ 4 files changed, 35 insertions(+), 12 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index fde12350..7d9ceaec 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -900,9 +900,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -941,9 +943,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty _ HsWildcardTy _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 651060c1..15bfae08 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -948,9 +948,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual - where ctxt' = case extra of - Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt - Nothing -> ctxt + where + anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + ctxt' + | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt + | otherwise = ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -1002,9 +1004,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual -ppr_mono_ty _ HsWildcardTy _ _ = char '_' +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 110c9a42..30074e4f 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -231,8 +231,7 @@ renameType t = case t of HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildcardTy -> pure HsWildcardTy - HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) @@ -254,6 +253,10 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') +renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name + renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead InstHead {..} = do cname <- rename ihdClsName diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 106d3544..7e01d88a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -38,6 +38,7 @@ import Coercion import NameSet import OccName import Outputable +import Control.Applicative (Applicative(..)) import Control.Monad (ap) import Haddock.Backends.Hyperlinker.Types @@ -646,3 +647,18 @@ instance Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) + + +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder -- cgit v1.2.3 From f6c317bf8828378549d48d68f118fd9f0f919f82 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Fri, 3 Jul 2015 15:57:06 +0200 Subject: StrictData: print correct strictness marks --- haddock-api/src/Haddock/Backends/LaTeX.hs | 7 +++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 7d9ceaec..e631acc6 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -825,8 +825,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ (Just True)) = char '!' +ppBang (HsSrcBang _ _ (Just False)) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 15bfae08..f01365e9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -865,9 +865,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" +ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index dd577319..e8ed148c 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -270,13 +270,13 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) True - HsStrict -> HsSrcBang Nothing (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) + HsStrict -> HsSrcBang Nothing (Just False) (Just True) + HsLazy -> HsSrcBang Nothing Nothing Nothing _ -> bang in case src_bang of - HsNoBang -> tySyn + (HsSrcBang _ Nothing Nothing) -> tySyn _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. ) arg_tys (dataConSrcBangs dc) field_tys = zipWith (\field synTy -> noLoc $ ConDeclField -- cgit v1.2.3 From 2d38f9b34a19b77f4260e8a0291156dace1d63fc Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Wed, 8 Jul 2015 15:03:04 +0200 Subject: StrictData: changes in HsBang type --- haddock-api/src/Haddock/Backends/LaTeX.hs | 10 +++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 8 ++++---- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e631acc6..df2e6b61 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -825,11 +825,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' -ppBang (HsSrcBang _ _ (Just True)) = char '!' -ppBang (HsSrcBang _ _ (Just False)) = char '~' -ppBang _ = empty +ppBang HsStrict = char '!' +ppBang (HsUnpack {}) = char '!' +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f01365e9..d0e7f890 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -865,11 +865,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" -ppBang (HsSrcBang _ _ (Just True)) = toHtml "!" -ppBang (HsSrcBang _ _ (Just False)) = toHtml "~" -ppBang _ = noHtml +ppBang HsStrict = toHtml "!" +ppBang (HsUnpack {}) = toHtml "!" +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index e8ed148c..e6361ed1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -270,12 +270,12 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True) - HsStrict -> HsSrcBang Nothing (Just False) (Just True) - HsLazy -> HsSrcBang Nothing Nothing Nothing + HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict + HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict + HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness _ -> bang in case src_bang of - (HsSrcBang _ Nothing Nothing) -> tySyn + (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn _ -> noLoc $ HsBangTy bang tySyn ) arg_tys (dataConSrcBangs dc) -- cgit v1.2.3 From 81653061d333a1e7d6024e132b1a72a947b9b0ab Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 26 Jul 2015 22:19:40 +0200 Subject: Replace (SourceText,FastString) with WithSourceText data type Phab:D907 introduced SourceText for a number of data types, by replacing FastString with (SourceText,FastString). Since this has an Outputable instance, no warnings are generated when ppr is called on it, but unexpected output is generated. See Phab:D1096 for an example of this. Replace the (SourceText,FastString) tuples with a new data type data WithSourceText = WithSourceText SourceText FastString Trac ticket: #10692 --- haddock-api/src/Haddock/Interface/Create.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 8b4605a7..d8f49edc 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -48,6 +48,7 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) +import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -164,7 +165,7 @@ mkAliasMap dflags mRenamedSource = return $ (lookupModuleDyn dflags (fmap Module.fsToPackageKey $ - fmap snd $ ideclPkgQual impDecl) + fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -200,8 +201,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (snd . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs -- cgit v1.2.3 From ebf0eeb4dc364859016fb6984091ae585c8d3053 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Tue, 14 Jul 2015 21:01:01 +0200 Subject: HsBang is split into HsSrcBang and HsImplBang With recent changes in GHC handling of strictness annotations in Haddock is simplified. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +--- haddock-api/src/Haddock/Convert.hs | 20 ++++++++------------ 3 files changed, 10 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index df2e6b61..75ad51ab 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -824,9 +824,7 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' +ppBang :: HsSrcBang -> LaTeX ppBang (HsSrcBang _ _ SrcStrict) = char '!' ppBang (HsSrcBang _ _ SrcLazy) = char '~' ppBang _ = empty diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d0e7f890..69393a37 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -864,9 +864,7 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" +ppBang :: HsSrcBang -> Html ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" ppBang _ = noHtml diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index e6361ed1..7a8b1acb 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -267,18 +267,14 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict - HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict - HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness - _ -> bang - in case src_bang of - (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - ) - arg_tys (dataConSrcBangs dc) + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLoc $ HsBangTy bang' tySyn) + arg_tys (dataConSrcBangs dc) + field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys -- cgit v1.2.3 From 7f34b4ee53a82124f45895c74f41b50fc7aa71e7 Mon Sep 17 00:00:00 2001 From: Thomas Miedema Date: Sat, 15 Aug 2015 14:51:18 +0200 Subject: Follow changes in GHC build system --- ghc.mk | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghc.mk b/ghc.mk index a3bb834f..af2d8de3 100644 --- a/ghc.mk +++ b/ghc.mk @@ -59,9 +59,9 @@ endif .PHONY: install_utils/haddock_data install_utils/haddock_data: $(foreach i,$(sort $(dir $(utils/haddock_dist_DATA_FILES))), \ - $(call make-command,$(call INSTALL_DIR,"$(DESTDIR)$(ghclibdir)/$i"))) + $(call make-command,$(INSTALL_DIR) "$(DESTDIR)$(ghclibdir)/$i")) $(foreach i,$(utils/haddock_dist_DATA_FILES), \ - $(call make-command,$(call INSTALL_DATA,$(INSTALL_OPTS),utils/haddock/haddock-api/resources/$i,"$(DESTDIR)$(ghclibdir)/$(dir $i)"))) + $(call make-command,$(INSTALL_DATA) $(INSTALL_OPTS) utils/haddock/haddock-api/resources/$i "$(DESTDIR)$(ghclibdir)/$(dir $i)")) .PHONY: install_utils/haddock_link install_utils/haddock_link: -- cgit v1.2.3 From df0988170814b5e5e0e9015eb28c249b08a2d6de Mon Sep 17 00:00:00 2001 From: Eric Seidel Date: Thu, 4 Jun 2015 20:29:56 -0700 Subject: account for changes to ipClass --- haddock-api/src/Haddock/Convert.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 7a8b1acb..24947876 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -29,14 +29,13 @@ import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn -import PrelNames (ipClassName) import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) import TypeRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) +import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) import Var @@ -350,7 +349,7 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | tyConName tc == ipClassName + | tc == ipTyCon , [name, ty] <- tys , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- cgit v1.2.3 From 37a1603cd81a117d107a8468f342a0f56af6f64e Mon Sep 17 00:00:00 2001 From: Jan Stolarek Date: Fri, 19 Dec 2014 08:16:30 +0100 Subject: Follow changes from #6018 --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++++++--- haddock-api/src/Haddock/Convert.hs | 42 +++++++++++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 34 +++++++++++++++++---- 3 files changed, 96 insertions(+), 22 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 69393a37..bc16bdcd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -257,12 +257,32 @@ ppFamilyKind _ _ Nothing = noHtml ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) unicode qual = - ppFamilyInfo associated info <+> - ppFamDeclBinderWithVars summary d <+> - ppFamilyKind unicode qual mkind - + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + + (case result of + NoSig -> noHtml + KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + ) <+> + + (case injectivity of + Nothing -> noHtml + Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn + ) ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName -> Html @@ -271,6 +291,11 @@ ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> ppFamilyKind unicode qual pfdKindSig +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = + char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> + hsep (map (ppLDocName qual Raw) rhs) + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> @@ -913,6 +938,13 @@ ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr _ qual (UserTyVar name ) = + ppDocName qual Raw False name +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 24947876..cf8b8243 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,7 +26,7 @@ import Data.List( partition ) import DataCon import FamInstEnv import HsSyn -import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) @@ -37,6 +37,7 @@ import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) import Unique ( getUnique ) +import Util ( filterByList ) import Var import Haddock.Types @@ -166,7 +167,8 @@ synifyTyCon coax tc | isTypeFamilyTyCon tc = case famTyConFlav_maybe tc of Just rhs -> - let info = case rhs of + let resultVar = famTcResVar tc + info = case rhs of OpenSynFamilyTyCon -> return OpenTypeFamily ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) @@ -178,21 +180,25 @@ synifyTyCon coax tc AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily Nothing in info >>= \i -> - return (FamDecl - (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = - Just (synifyKindSig (synTyConResKind tc)) - })) + return (FamDecl (FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + })) Nothing -> Left "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' + FamDecl (FamilyDecl DataFamily (synifyName tc) + (synifyTyVars (tyConTyVars tc)) + (noLoc NoSig) -- always kind '*' + Nothing) -- no injectivity _ -> Left "synifyTyCon: impossible open data type?" | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc @@ -243,6 +249,20 @@ synifyTyCon coax tc , tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn Name) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLoc . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig Nothing kind = + noLoc $ KindSig (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLoc $ TyVarSig (noLoc $ KindedTyVar (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 -- result-type. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 30074e4f..6ec1f2c5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -176,6 +176,25 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind +renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig (L loc NoSig) + = return (L loc NoSig) +renameFamilyResultSig (L loc (KindSig ki)) + = do { ki' <- renameLKind ki + ; return (L loc (KindSig ki')) } +renameFamilyResultSig (L loc (TyVarSig bndr)) + = do { bndr' <- renameLTyVarBndr bndr + ; return (L loc (TyVarSig bndr')) } + +renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) + = do { lhs' <- renameL lhs + ; rhs' <- mapM renameL rhs + ; return (L loc (InjectivityAnn lhs' rhs')) } + +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) + -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -343,13 +362,16 @@ renameTyClD d = case d of renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind + , fdTyVars = ltyvars, fdResultSig = result + , fdInjectivityAnn = injectivity }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + result' <- renameFamilyResultSig result + injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) + , fdTyVars = ltyvars', fdResultSig = result' + , fdInjectivityAnn = injectivity' }) renamePseudoFamilyDecl :: PseudoFamilyDecl Name -- cgit v1.2.3 From 5aac8c97051760f4a13566c636a739f109acc4e1 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Mon, 21 Sep 2015 12:00:47 -0400 Subject: React to refactoring CoAxiom branch lists. --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index cf8b8243..b7aefd09 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -173,7 +173,7 @@ synifyTyCon coax tc ClosedSynFamilyTyCon mb -> case mb of Just (CoAxiom { co_ax_branches = branches }) -> return $ ClosedTypeFamily $ Just $ - brListMap (noLoc . synifyAxBranch tc) branches + map (noLoc . synifyAxBranch tc) (fromBranches branches) Nothing -> return $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily $ Just [] -- cgit v1.2.3 From 7a569775a5b10abed758b207e86c404034d543f4 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 25 Jul 2015 17:44:41 -0700 Subject: Track msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d8f49edc..169dad7a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -130,7 +130,9 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = msHsFilePath ms + , ifaceOrigFilename = case msHsFilePath ms of + Just path -> path + Nothing -> "(none)" , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From cda84b49bfb0e17557eddd9178267d3ee0d9b343 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Sat, 26 Sep 2015 16:23:00 +0200 Subject: Create Process: removed PhaseFailed --- haddock-api/src/Haddock.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8f327b09..b87c4cf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -121,11 +121,8 @@ handleGhcExceptions = -- error messages propagated as exceptions handleGhcException $ \e -> do hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure + print (e :: GhcException) + exitFailure ------------------------------------------------------------------------------- -- cgit v1.2.3 From 319acdd0c70d21c517aa09b3e35f87e9bc01ad8c Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sun, 11 Oct 2015 11:31:11 -0700 Subject: s/PackageKey/UnitId/g and s/packageKey/unitId/g Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/InterfaceFile.hs | 13 ++++++++----- haddock-api/src/Haddock/ModuleTree.hs | 6 +++--- 7 files changed, 22 insertions(+), 19 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index b87c4cf5..ef873500 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -255,8 +255,8 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces) - pkgKey = modulePackageKey pkgMod - pkgStr = Just (packageKeyString pkgKey) + pkgKey = moduleUnitId pkgMod + pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -353,7 +353,7 @@ modulePackageInfo dflags flags modu = cmdline <|> pkgDb where cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags - pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu) + pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index e5e4db3f..a1e4f94d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -304,7 +304,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule = thespan ! modAttrs << (cBtn +++ if leaf - then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d624a1d0..d24ed9c4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -271,7 +271,7 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n m -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageKey origMod + origPkg = moduleUnitId origMod fname = case loc of RealSrcSpan l -> unpackFS (srcSpanFile l) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index 3d1db887..d1561791 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 169dad7a..b0a4d621 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -166,7 +166,7 @@ mkAliasMap dflags mRenamedSource = alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageKey $ + (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -174,13 +174,13 @@ mkAliasMap dflags mRenamedSource = -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageKey -> ModuleName -> Module + DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = case Packages.lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainPackageKey mdlName + [] -> Module.mkModule Module.mainUnitId mdlName ------------------------------------------------------------------------------- @@ -704,8 +704,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageKey expMod - packageKey = modulePackageKey thisMod + m = mkModule unitId expMod + unitId = moduleUnitId thisMod -- Note [1]: diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 4f4218c9..73185092 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifModule, ifPackageKey, + InterfaceFile(..), ifUnitId, ifModule, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -57,8 +57,11 @@ ifModule if_ = [] -> error "empty InterfaceFile" iface:_ -> instMod iface -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey = modulePackageKey . ifModule +ifUnitId :: InterfaceFile -> UnitId +ifUnitId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> moduleUnitId $ instMod iface binaryInterfaceMagic :: Word32 @@ -312,7 +315,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (PackageKey, ModuleName, OccName) +type OnDiskName = (UnitId, ModuleName, OccName) fromOnDiskName @@ -342,7 +345,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) + put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 2f731214..e6cf8201 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) +import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) @@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short -- cgit v1.2.3 From 821b1dcfe62bf75711661348ac80a64cc60a0b6a Mon Sep 17 00:00:00 2001 From: Adam Gundry Date: Fri, 16 Oct 2015 16:26:42 +0100 Subject: Roughly fix up haddock for DuplicateRecordFields changes This compiles, but will probably need more work to produce good documentation when the DuplicateRecordFields extension is used. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 11 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++++---- haddock-api/src/Haddock/Convert.hs | 8 +++++--- haddock-api/src/Haddock/GhcUtils.hs | 3 ++- haddock-api/src/Haddock/Interface/Create.hs | 17 ++++++++++------- haddock-api/src/Haddock/Interface/Rename.hs | 8 ++++++-- haddock-api/src/Haddock/Types.hs | 4 ++-- haddock-api/src/Haddock/Utils.hs | 5 ++++- 9 files changed, 45 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f6ad9808..42887834 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -245,8 +245,8 @@ ppCtor dflags dat subdocs con 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) (cd_fld_names r)) ++ - [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(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]] | r <- map unLoc recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 75ad51ab..eae450a4 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -25,9 +25,10 @@ import qualified Pretty import GHC import OccName import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) +import RdrName ( rdrNameOcc, mkRdrUnqual ) import FastString ( unpackFS, unpackLitString, zString ) import Outputable ( panic) +import PrelNames ( mkUnboundName ) import qualified Data.Map as Map import System.Directory @@ -688,12 +689,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . 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 (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -902,7 +903,9 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC :: HsType DocName + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bc16bdcd..89b822d6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -38,6 +38,8 @@ import GHC import GHC.Exts import Name import BooleanFormula +import RdrName ( rdrNameOcc, mkRdrUnqual ) +import PrelNames ( mkUnboundName ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -848,18 +850,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, + (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, 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 (unL $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -981,7 +983,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard PlaceHolder) + anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b7aefd09..f12556f8 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,6 +28,7 @@ import FamInstEnv import HsSyn import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name +import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) @@ -294,9 +295,10 @@ synifyDataCon use_gadt_syntax dc = bang' -> noLoc $ HsBangTy bang' tySyn) arg_tys (dataConSrcBangs dc) - field_tys = zipWith (\field synTy -> noLoc $ ConDeclField - [synifyName field] synTy Nothing) - (dataConFieldLabels dc) linear_tys + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLoc $ + ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index ce4ca38a..0581ceb8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -188,7 +188,8 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) + RecCon fields -> map (selectorFieldOcc . unL) $ + concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b0a4d621..7a5eb8d7 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -337,15 +337,16 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] + dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- con_names c ] - fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , n <- ns ] + , L _ n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -507,7 +508,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEThingWith (L _ t) _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ @@ -802,7 +803,7 @@ extractDecl name mdl decl , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) @@ -833,11 +834,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] + matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 6ec1f2c5..1671a38d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -273,7 +273,7 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard _) = pure (AnonWildCard PlaceHolder) +renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) @@ -429,11 +429,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do - names' <- mapM renameL names + names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') +renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc (L l (FieldOcc lbl sel)) = do + sel' <- rename sel + return $ L l (FieldOcc lbl sel') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 7e01d88a..dd41b523 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -296,7 +296,6 @@ type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder type instance PostTc DocName Coercion = PlaceHolder - instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -656,8 +655,9 @@ instance Monad ErrMsgGhc where type instance PostRn DocName NameSet = PlaceHolder type instance PostRn DocName Fixity = PlaceHolder type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = PlaceHolder +type instance PostRn DocName Name = DocName type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..c2e1b09a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,6 +63,7 @@ import Haddock.GhcUtils import GHC import Name +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns + field_avail :: LConDeclField Name -> Bool + field_avail (L _ (ConDeclField fs _ _)) + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3 From 4e1eef5c7e79717af2c8d72234e4c82f8a11c443 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 26 Oct 2015 12:52:36 +0000 Subject: Track wip/spj-wildcard-refactor on main repo --- haddock-api/src/Haddock/Backends/Hoogle.hs | 33 ++++++---------- haddock-api/src/Haddock/Convert.hs | 33 +++++++++------- haddock-api/src/Haddock/GhcUtils.hs | 12 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 61 ++++++++++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 2 +- 5 files changed, 80 insertions(+), 61 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 42887834..afa694e3 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -68,7 +68,8 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) + 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) @@ -85,14 +86,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -129,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ f (SigD sig) = ppSig dflags sig ++ ppFixities f _ = [] @@ -138,7 +131,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig _) subdocs +ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) @@ -148,10 +141,7 @@ ppSigWithDoc dflags (TypeSig names sig _) subdocs getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = case unL sig of - HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d - HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d - x -> x + typ = unL (hsSigType sig) ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] @@ -183,12 +173,13 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods , rbrace ] - addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs + addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d - f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) + f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) + f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty + f ty = HsQualTy (reL [context]) ty context = nlHsTyConApp (tcdName decl) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) @@ -249,10 +240,10 @@ ppCtor dflags dat subdocs con [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + funs = foldr1 (\x y -> reL $ HsFunTy x y) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f12556f8..bad99f24 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -97,7 +97,7 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc)) []) + (synifyType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps @@ -119,10 +119,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name - , tfe_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs - , hswb_wcs = [] } + , tfe_pats = HsIB { hsib_body = typats + , hsib_kvs = map tyVarName kvs + , hsib_tvs = map tyVarName tvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -311,8 +310,14 @@ synifyDataCon use_gadt_syntax dc = else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care - qvars ctx hat hs_res_ty Nothing + \hat -> return $ noLoc $ + ConDecl { con_names = [name] + , con_explicit = False -- we don't know nor care + , con_qvars = qvars + , con_cxt = ctx + , con_details = hat + , con_res = hs_res_ty + , con_doc = Nothing } -- we don't want any "deprecated GADT syntax" warnings! False @@ -328,7 +333,7 @@ synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars :: [TyVar] -> LHsQTyVars Name synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where @@ -394,15 +399,13 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - mkHsForAllTy forallPlicitness = - noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) + , hst_body = noLoc (synify WithinType tau) } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> mkHsForAllTy Explicit - ImplicitizeForAll -> mkHsForAllTy Implicit + WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + , hst_body = noLoc sPhi } + ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 0581ceb8..e2aa8f06 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -68,7 +68,7 @@ getMainDeclBinder _ = [] -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances @@ -91,10 +91,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) = [] -> Nothing filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty nwcs) = +filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty nwcs) + filtered -> Just (TypeSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -105,8 +105,8 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _ _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns @@ -198,7 +198,7 @@ instance Parent (TyClDecl Name) 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 = [] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1671a38d..61eb6cde 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLSigType = renameWc renameLType + +renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) +renameLWcSigType = renameImplicit renameLSigType + renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl extra tyvars lcontext ltype -> do + HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- renameLTyVarBndrs tyvars + ltype' <- renameLType ltype + return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + + HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl extra tyvars' lcontext' ltype') + return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype @@ -252,7 +262,7 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } @@ -441,16 +451,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype _ -> do + TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLType ltype - return (TypeSig lnames' ltype' PlaceHolder) + ltype' <- renameLWcSigType ltype + return (TypeSig lnames' ltype') PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - lty' <- renameLType lty + lty' <- renameLSigType lty return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames @@ -463,11 +473,11 @@ renameSig sig = case sig of renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignImport lname' ltype' co x) renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype return (ForeignExport lname' ltype' co x) @@ -502,33 +512,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) , tfid_fvs = placeHolderNames }) } renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_pats = pats' , tfe_rhs = rhs' })) } renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + = do { tc' <- renameL tc + ; tvs' <- renameLTyVarBndrs tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' , tfe_rhs = rhs' })) } renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; pats' <- renameImplicit (mapM renameLType) pats ; defn' <- renameDataDefn defn ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats - = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , dfid_pats = pats' , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameImplicit :: (in_thing -> RnM out_thing) + -> HsImplicitBndrs Name in_thing + -> RnM (HsImplicitBndrs DocName out_thing) +renameImplicit rn_thing (HsIB { hsib_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsIB { hsib_body = thing' + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + +renameWc :: (in_thing -> RnM out_thing) + -> HsWildcardBndrs Name in_thing + -> RnM (HsWildcardBndrs DocName out_thing) +renameWc rn_thing (HsWC { hswc_body = thing }) + = do { thing' <- rn_thing thing + ; return (HsWC { hswc_body = thing' + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index c2e1b09a..3964c86a 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsTyVarBndrs Name +emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -- cgit v1.2.3 From 5628084e7a9d7bf8ec083cd93321eaa6ac686b4a Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 17:34:18 +0000 Subject: Follow changes to HsTYpe Not yet complete (but on a wip/ branch) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 35 ++++++++------------ haddock-api/src/Haddock/Convert.hs | 46 ++++++++++++++------------ haddock-api/src/Haddock/Interface/Create.hs | 48 ++++++++------------------- haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++--------------- haddock-api/src/Haddock/Utils.hs | 29 ++++++++++++++++ 5 files changed, 105 insertions(+), 104 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index afa694e3..1d85b474 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + 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 ++ ppFixities f _ = [] @@ -135,31 +135,33 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [mkSig n] - mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + ++ [pp_sig dflags names (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = unL (hsSigType sig) + typ = unL (hsSigWcType sig) ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] ppSig dflags x = ppSigWithDoc dflags x [] +pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig dflags names (L _ typ) = + operator prettyNames ++ " :: " ++ outHsType dflags typ + where + prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods +ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - decl' = decl - { tcdSigs = [], tcdMeths = emptyBag - , tcdATs = [], tcdATDefs = [] - } - ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl + ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) + ppTyFams | null $ tcdATs decl = "" | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat @@ -173,17 +175,6 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods , rbrace ] - addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig))) - addContext (MinimalSig src sig) = MinimalSig src sig - addContext _ = error "expected TypeSig" - - f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty)) - f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty - f ty = HsQualTy (reL [context]) ty - - context = nlHsTyConApp (tcdName decl) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl))) - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index bad99f24..7f807569 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -97,17 +97,10 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps - qtvs = univ_tvs ++ ex_tvs - ty = mkFunTys arg_tys res_ty - in allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -317,16 +310,16 @@ synifyDataCon use_gadt_syntax dc = , con_cxt = ctx , con_details = hat , con_res = hs_res_ty - , con_doc = Nothing } + , con_doc = Nothing -- we don't want any "deprecated GADT syntax" warnings! - False + , con_old_rec = False } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] +synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name @@ -338,12 +331,14 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs , hsq_tvs = map synifyTyVar tvs } where (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv + +synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -361,6 +356,15 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! +synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +-- The empty binders is a bit suspicious; +-- what if the type has free variables? +synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) + +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +-- Ditto (see synifySigType) +synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) + synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) @@ -399,11 +403,11 @@ synifyType _ (FunTy t1 t2) = let in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx) - , hst_body = noLoc (synify WithinType tau) } + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs + WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7a5eb8d7..11906efa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -353,15 +353,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty _) -> docs (unLoc ty) - SigD (PatSynSig _ _ req prov ty) -> - let allTys = ty : concat [ unLoc req, unLoc prov ] - in F.foldMap (docs . unLoc) allTys - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) + SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) + ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) + 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 @@ -740,8 +739,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) @@ -785,17 +784,17 @@ extractDecl name mdl decl case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity + isTypeLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 + [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl (ClassDecl)" TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) + in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } + , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> @@ -809,24 +808,6 @@ extractDecl name mdl decl [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc - - -extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of - L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) - where - lctxt = noLoc . ctxt - ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name @@ -835,7 +816,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm mdl t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] @@ -845,7 +826,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) = | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 61eb6cde..3a170f4a 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -170,11 +170,11 @@ renameFnArgsDoc = mapM renameDoc renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType -renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLSigType = renameWc renameLType +renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType = renameImplicit renameLType -renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName) -renameLWcSigType = renameImplicit renameLSigType +renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType = renameImplicit (renameWc renameLType) renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType @@ -205,11 +205,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) - HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do + HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) @@ -262,10 +262,10 @@ renameType t = case t of HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a -renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -338,13 +338,13 @@ renameTyClD d = case d of SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars + tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) @@ -352,7 +352,7 @@ renameTyClD d = case d of , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats @@ -376,7 +376,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity return (FamilyDecl { fdInfo = info', fdLName = lname' @@ -415,7 +415,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - ltyvars' <- renameLTyVarBndrs ltyvars + ltyvars' <- renameLHsQTyVars ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype @@ -453,15 +453,12 @@ renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames - ltype' <- renameLWcSigType ltype + ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') - PatSynSig lname (flag, qtvs) lreq lprov lty -> do + PatSynSig lname sig_ty -> do lname' <- renameL lname - qtvs' <- renameLTyVarBndrs qtvs - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - lty' <- renameLSigType lty - return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + sig_ty' <- renameLSigType sig_ty + return $ PatSynSig lname' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) @@ -496,7 +493,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype + ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs return (ClsInstDecl { cid_overlap_mode = omode @@ -523,7 +520,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) = do { tc' <- renameL tc - ; tvs' <- renameLTyVarBndrs tvs + ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs ; return (L loc (TyFamEqn { tfe_tycon = tc' , tfe_pats = tvs' @@ -544,15 +541,15 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) + , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildcardBndrs Name in_thing - -> RnM (HsWildcardBndrs DocName out_thing) + -> HsWildCardBndrs Name in_thing + -> RnM (HsWildCardBndrs DocName out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) + , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3964c86a..6a499f64 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -16,6 +16,7 @@ module Haddock.Utils ( -- * Misc utilities restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, + mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, -- * Filename utilities moduleHtmlFile, moduleHtmlFile', @@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } +mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) + +addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +-- Add the class context to a class-op signature +addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) + = L pos (TypeSig 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 }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { 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 }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar (hsLTyVarName tv)) + | tv <- hsQTvBndrs tvs ] + -------------------------------------------------------------------------------- -- * Making abstract declarations -------------------------------------------------------------------------------- -- cgit v1.2.3 From 0b4e5424d1df869cc6eb4bc439c7988f36eeaab4 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 30 Oct 2015 13:03:51 +0000 Subject: Work on updating Haddock to wip/spj-wildard-recactor Still incomplete --- haddock-api/src/Haddock/Backends/LaTeX.hs | 143 ++++++++++--------------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 17 ++- haddock-api/src/Haddock/Utils.hs | 2 +- 3 files changed, 63 insertions(+), 99 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index eae450a4..79aa1177 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -214,9 +214,9 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) + | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -251,8 +251,8 @@ ppDocGroup lev doc = sec lev <> braces doc declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] - SigD (TypeSig lnames _ _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + SigD (TypeSig lnames _ ) -> map unLoc lnames + SigD (PatSynSig lname _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -294,10 +294,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- TyClD d@(TySynonym {}) -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode + 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 lname ty) -> + ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -312,8 +313,8 @@ ppTyFam _ _ _ _ _ = ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode +ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -330,7 +331,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" @@ -341,9 +344,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = +ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names @@ -353,29 +356,17 @@ ppFunSig loc doc docnames typ unicode = names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> (HsExplicitFlag, LHsTyVarBndrs DocName) - -> LHsContext DocName -> LHsContext DocName - -> LHsType DocName + -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode +ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode - , ctx - , ppType unicode ty + , ppLType unicode (hsSigType ty) ] - ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of - (Nothing, Nothing) -> empty - (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode - ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX @@ -395,22 +386,14 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Qualified e a lctxt ltype) - = do_args n leader (HsForAllTy Implicit e a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype + do_args _n leader (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 @@ -425,12 +408,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -479,12 +462,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -522,8 +505,8 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -615,21 +598,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") where ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Qualified -> empty - Implicit -> empty + True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + False -> empty ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = +ppSideBySideConstr subdocs unicode leader (L loc con) = leader <-> case con_res con of ResTyH98 -> case con_details con of @@ -663,13 +645,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = doRecordFields fields = vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] + doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) ) <-> rDoc mbDoc - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr (con_explicit con) tyVars context occ = map (nameOccName . getName . unLoc) $ con_names con ppOcc = case occ of [one] -> ppBinder one @@ -677,7 +659,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs 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 @@ -793,9 +780,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode @@ -881,34 +865,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode - -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Bool -> LaTeX -ppLTyVarBndrs expl tvs unicode - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - | otherwise = empty - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} - ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] - where - anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt + 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 name) _ = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 89b822d6..0461ad41 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -50,8 +50,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname qtvs prov req ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual + SigD (PatSynSig lname ty) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -74,23 +74,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = pp_typ = ppType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - (HsExplicitFlag, LHsTyVarBndrs DocName) -> - LHsContext DocName -> LHsContext DocName -> - LHsType DocName -> + Located DocName -> LHsSigType DocName [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual | summary = pref1 | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppBinder summary occname + , ppDocBinder name , dcolon unicode - , ppLTyVarBndrs expl qtvs unicode qual - , cxt - , ppLType unicode qual typ + , ppLType unicode (hsSigType ty) ] cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 6a499f64..f7a32dd3 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -132,7 +132,7 @@ mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name -- Add the class context to a class-op signature -addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype)) +addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where -- cgit v1.2.3 From 3fd2ed3213778c090ed5e27bd8a9e5bdee5c5135 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Sat, 31 Oct 2015 19:08:13 +0000 Subject: More adaption to wildcard-refactor --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 162 +++++++++++++------------ 3 files changed, 85 insertions(+), 81 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 79aa1177..b89656d3 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -385,7 +385,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args :: Int -> LaTeX -> HsType DocName -> LaTeX do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index a1e4f94d..1554a33c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -583,7 +583,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames (L _ _) _) -> + SigD (TypeSig lnames _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0461ad41..4f0a22ca 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -45,13 +45,14 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname ty) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigWcType lty) fixities splice unicode qual + SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname + ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -61,20 +62,20 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) splice unicode qual where - pp_typ = ppType unicode qual typ + pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> LHsSigType DocName + Located DocName -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual @@ -83,18 +84,11 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unico +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppDocBinder name + , ppBinder summary occname , dcolon unicode - , ppLType unicode (hsSigType ty) + , ppLType unicode qual (hsSigType typ) ] - cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of - (Nothing, Nothing) -> noHtml - (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr - (Just prov, Nothing) -> prov <+> darr - (Just prov, Just req) -> prov <+> darr <+> req <+> darr - - darr = darrow unicode occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -128,22 +122,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy _ _ tvs lctxt ltype) - = case unLoc lctxt of - [] -> do_largs n leader' ltype - _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - where leader' = leader <+> ppForAll tvs unicode qual + 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) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs 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 $ @@ -171,20 +172,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge rightEdge = thespan ! [theclass "rightedge"] << noHtml -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs - -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames +tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities +ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -199,7 +199,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode qual where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars (hsQTvBndrs ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -318,7 +319,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsWB { hswb_cts = ts }} + , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) @@ -403,10 +404,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc - -ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html -ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc - ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual @@ -437,7 +434,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] + -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -470,8 +467,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- sigs + [ ppFunSig summary links loc doc names (hsSigWcType typ) + [] splice unicode qual + | L _ (TypeSig 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 @@ -517,8 +515,9 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | TypeSig lnames (L _ typ) _ <- sigs + methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + subfixs splice unicode qual + | L _ (ClassOpSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -531,12 +530,12 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | MinimalSig _ s <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns] + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | TypeSig ns _ _ <- sigs, L _ n' <- ns] + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -767,23 +766,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") + (if null ctxt then noHtml + else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Qualified -> noHtml - Implicit -> noHtml - + ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) +ppSideBySideConstr subdocs fixities unicode qual (L loc con) + = (decl, mbDoc, fieldPart) where decl = case con_res con of ResTyH98 -> case con_details con of @@ -813,12 +812,19 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] + <+> ppLType unicode qual (mk_forall $ mk_phi $ + foldr mkFunTy resTy args) <+> fixity + mk_phi ty | null context = ty + | otherwise = L loc (HsQualTy (con_cxt con) ty) + + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + | otherwise = ty + fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual occ = map (nameOccName . getName . unLoc) $ con_names con @@ -951,38 +957,36 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAllCon :: Bool -> LHsQTyVars DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html ppForAllCon expl tvs cxt unicode qual = forall_part <+> ppLContext cxt unicode qual where forall_part = ppLTyVarBndrs expl tvs unicode qual -ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Unicode -> Qualification - -> Html -ppLTyVarBndrs expl tvs unicode _qual - | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - | otherwise = noHtml +ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html +ppLTyVarBndrs show_forall tvs unicode _qual + | show_forall + , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode + | otherwise = noHtml where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} + tv_bndrs = hsQTvBndrs tvs +ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html +ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual - <+> ppr_mono_lty pREC_TOP ty unicode qual - where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) - underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) - ctxt' - | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt - | otherwise = ctxt +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual + +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ -- cgit v1.2.3 From 617392c5df94fae16261e1d298ce5c87575233c8 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 27 Oct 2015 14:24:56 +0000 Subject: Track change to PatSyn.patSynSig --- haddock-api/src/Haddock/Convert.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 7f807569..2458f027 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -100,7 +100,14 @@ tyThingToLHsDecl t = case t of (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps)) + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + qtvs = univ_tvs ++ ex_tvs + ty = mkFunTys arg_tys res_ty + in allOK . SigD $ PatSynSig (synifyName ps) + (Implicit, synifyTyVars qtvs) + (synifyCtx req_theta) + (synifyCtx prov_theta) + (synifyType WithinType ty) where withErrs e x = return (e, x) allOK x = return (mempty, x) -- cgit v1.2.3 From 3e6b341a7bc2331a1646760f20f2451932d725d6 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 23 Sep 2015 18:43:18 +0200 Subject: Account for Typeable changes The treatment of type families changed. --- haddock-api/src/Haddock/Convert.hs | 69 ++++++++++++++++++-------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 2458f027..e563ac08 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -141,7 +141,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) -- | Turn type constructors into type class declarations synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon coax tc +synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc @@ -164,42 +164,37 @@ synifyTyCon coax tc , dd_derivs = Nothing } , tcdFVs = placeHolderNamesTc } - | isTypeFamilyTyCon tc - = case famTyConFlav_maybe tc of - Just rhs -> - let resultVar = famTcResVar tc - info = case rhs of - OpenSynFamilyTyCon -> return OpenTypeFamily - ClosedSynFamilyTyCon mb -> case mb of - Just (CoAxiom { co_ax_branches = branches }) - -> return $ ClosedTypeFamily $ Just $ - map (noLoc . synifyAxBranch tc) (fromBranches branches) - Nothing -> return $ ClosedTypeFamily $ Just [] - BuiltInSynFamTyCon {} - -> return $ ClosedTypeFamily $ Just [] - AbstractClosedSynFamilyTyCon {} - -> return $ ClosedTypeFamily Nothing - in info >>= \i -> - return (FamDecl (FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) - , fdInjectivityAnn = - synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) - })) - Nothing -> Left "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> return $ - FamDecl (FamilyDecl DataFamily (synifyName tc) - (synifyTyVars (tyConTyVars tc)) - (noLoc NoSig) -- always kind '*' - Nothing) -- no injectivity - _ -> Left "synifyTyCon: impossible open data type?" +synifyTyCon _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = famTcResVar tc + mkFamDecl i = return $ FamDecl $ + FamilyDecl { fdInfo = i + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (familyTyConInjectivityInfo tc) + } + +synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConTyVars tc) -- cgit v1.2.3 From af8fff4ee14e7e9fc8c6cedc96c57bd12b34c23c Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 31 Oct 2015 11:01:45 +0100 Subject: Relax upper bound on `base` to allow base-4.9 --- haddock-api/haddock-api.cabal | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b4ceb1a0..26bb1d94 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -38,7 +38,7 @@ library Haskell2010 build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 , bytestring , filepath , directory diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index c2ea73b0..f60501f5 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -21,7 +21,7 @@ library default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.9 + base >= 4.5 && < 4.10 , bytestring , transformers , deepseq diff --git a/haddock.cabal b/haddock.cabal index 6b5a8044..55af3c05 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -47,7 +47,7 @@ executable haddock ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded build-depends: - base >= 4.3 && < 4.9 + base >= 4.3 && < 4.10 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE -- cgit v1.2.3 From e27200a8aa4036727b2dbd454d52ab4d44b144b2 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 27 Oct 2015 16:12:50 +0200 Subject: Matching change GHC #11017 BooleanFormula located --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 ++++++----- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +++- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4f0a22ca..e6220ff2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -527,10 +527,10 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | MinimalSig _ s <- sigs ] of + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method @@ -545,9 +545,10 @@ ppClassDecl summary links instances fixities loc d subdocs _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances links (OriginClass nm) instances splice unicode qual diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index e563ac08..b829a5fd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -79,7 +79,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 mempty . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 11906efa..6f0254c5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -562,7 +562,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -760,7 +760,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 3a170f4a..f0ae4cf6 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -462,7 +462,9 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig src s -> MinimalSig src <$> traverse renameL s + MinimalSig src (L l s) -> do + s' <- traverse renameL s + return $ MinimalSig src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3 From e02a744ba29b7b8c904563c42b59e781f586491b Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Sun, 1 Nov 2015 12:08:58 +0000 Subject: Change for IEThingWith --- haddock-api/src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6f0254c5..ba3cee25 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -507,7 +507,7 @@ mkExportItems lookupExport (IEVar (L _ x)) = declWith x lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _) = declWith t + lookupExport (IEThingWith (L _ t) _ _ _) = declWith t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ -- cgit v1.2.3 From 064a7dfb98c197cd04f596aa7593b56cc93b63b6 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 11 Nov 2015 11:35:51 +0100 Subject: Eliminate support for deprecated GADT syntax Follows from GHC D1460. --- haddock-api/src/Haddock/Convert.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b829a5fd..ddf8f6b3 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -307,14 +307,12 @@ synifyDataCon use_gadt_syntax dc = in hs_arg_tys >>= \hat -> return $ noLoc $ ConDecl { con_names = [name] - , con_explicit = False -- we don't know nor care + , con_explicit = Implicit -- we don't know nor care , con_qvars = qvars , con_cxt = ctx , con_details = hat , con_res = hs_res_ty - , con_doc = Nothing - -- we don't want any "deprecated GADT syntax" warnings! - , con_old_rec = False } + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -- cgit v1.2.3 From 22aef2dd92e488af31556b8b4c1e034d6eb25de9 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Fri, 13 Nov 2015 21:56:18 -0800 Subject: Undo msHsFilePath change. Signed-off-by: Edward Z. Yang --- haddock-api/src/Haddock/Interface/Create.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ba3cee25..1c2cf5c9 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -130,9 +130,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceOrigFilename = case msHsFilePath ms of - Just path -> path - Nothing -> "(none)" + , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing -- cgit v1.2.3 From d74b8d0e5ab3589d3ab8cf82e22ab6ac6813ae40 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 21 Nov 2015 21:16:12 +0200 Subject: Update to match GHC wip/T11019 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 ++++---- haddock-api/src/Haddock/Convert.hs | 6 +++--- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 10 +++++----- haddock-api/src/Haddock/Types.hs | 13 +++++++------ 7 files changed, 23 insertions(+), 22 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1d85b474..5800736f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -241,7 +241,7 @@ ppCtor dflags dat subdocs con name = commaSeparate dflags . map unL $ con_names con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ + ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT _ x -> x diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b89656d3..a71ae784 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -880,7 +880,7 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -918,7 +918,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e6220ff2..5f5a9e61 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -943,7 +943,7 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html -ppHsTyVarBndr _ qual (UserTyVar name ) = +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> @@ -990,12 +990,12 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ +ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -1041,7 +1041,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ddf8f6b3..3b6657c2 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -334,7 +334,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv @@ -366,7 +366,7 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -391,7 +391,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) + (noLoc $ HsTyVar $ noLoc (getName tc)) (map (synifyType WithinType) tys) synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 1c2cf5c9..5ce4e6e6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -822,7 +822,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f0ae4cf6..4804faff 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -214,7 +214,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -269,9 +269,9 @@ renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -283,8 +283,8 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name -renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead InstHead {..} = do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index dd41b523..9db11be6 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -652,12 +652,13 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = DocName +type instance PostRn DocName (Located Name) = Located DocName +type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder -- cgit v1.2.3 From f310809a04592f8841583a2e146021d68f9a8432 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 23 Nov 2015 17:17:18 +0000 Subject: Wibble --- haddock-api/src/Haddock/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index f7a32dd3..658007ba 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -150,7 +150,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (hsLTyVarName tv)) + = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) | tv <- hsQTvBndrs tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3 From 3f503bd54678ec9ea611ba81360b573eb745e7b0 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sat, 5 Dec 2015 00:29:55 +0100 Subject: Canonicalise Monad instances --- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Types.hs | 10 +++++----- .../attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs | 6 +++--- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 4804faff..2183d8f2 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -91,13 +91,13 @@ newtype RnM a = instance Monad RnM where (>>=) = thenRn - return = returnRn + return = pure instance Functor RnM where fmap f x = do a <- x; return (f a) instance Applicative RnM where - pure = return + pure = returnRn (<*>) = ap returnRn :: a -> RnM a diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 9db11be6..e07f55f1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -586,11 +586,11 @@ instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) instance Applicative ErrMsgM where - pure = return - (<*>) = ap + pure a = Writer (a, []) + (<*>) = ap instance Monad ErrMsgM where - return a = Writer (a, []) + return = pure m >>= k = Writer $ let (a, w) = runWriter m (b, w') = runWriter (k a) @@ -639,11 +639,11 @@ instance Functor ErrMsgGhc where fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) instance Applicative ErrMsgGhc where - pure = return + pure a = WriterGhc (return (a, [])) (<*>) = ap instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) + return = pure m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs index 6719e09a..9c7994e9 100644 --- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs @@ -126,7 +126,7 @@ instance Monad (Parser i) where where msg = "Failed reading: " ++ err {-# INLINE fail #-} - return v = Parser $ \t pos more _lose succ -> succ t pos more v + return = pure {-# INLINE return #-} m >>= k = Parser $ \t !pos more lose succ -> @@ -158,7 +158,7 @@ apP d e = do {-# INLINE apP #-} instance Applicative (Parser i) where - pure = return + pure v = Parser $ \t pos more _lose succ -> succ t pos more v {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} @@ -166,7 +166,7 @@ instance Applicative (Parser i) where -- These definitions are equal to the defaults, but this -- way the optimizer doesn't have to work so hard to figure -- that out. - (*>) = (>>) + m *> k = m >>= \_ -> k {-# INLINE (*>) #-} x <* y = x >>= \a -> y >> return a {-# INLINE (<*) #-} -- cgit v1.2.3 From 5b07e7132ede1eefd2bc52604517434e960c87cb Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 17:33:52 +0200 Subject: Matching changes for #11028 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 19 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 71 ++++++++++++++- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 ++++++++----------------- haddock-api/src/Haddock/Convert.hs | 24 ++--- haddock-api/src/Haddock/GhcUtils.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 13 +-- haddock-api/src/Haddock/Interface/Rename.hs | 28 +++--- haddock-api/src/Haddock/Utils.hs | 20 ++++- 8 files changed, 176 insertions(+), 121 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5800736f..cef0da20 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -221,8 +221,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con - = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) +ppCtor dflags dat subdocs con@ConDeclH98 {} + -- AZ:TODO get rid of the concatMap + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] @@ -238,12 +239,18 @@ ppCtor dflags dat subdocs con -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ con_names con + name = commaSeparate dflags . map unL $ getConNames con - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ + resType = apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT _ x -> x + +ppCtor dflags _dat subdocs con@ConDeclGADT {} + = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f + where + f = [typeSig name (hsib_body $ con_type con)] + + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) + name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index a71ae784..e7780d6e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -577,14 +577,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode where cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + resTy = (unLoc . head) cons body = catMaybes [constrBit, doc >>= documentationToLaTeX] (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit @@ -609,6 +609,71 @@ ppConstrHdr forall tvs ctxt unicode False -> empty +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> 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 + + 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 []) (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) + + where + doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> + ppLType unicode resTy + ) <-> rDoc mbDoc + + 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. + mbDoc = case getConNames con of + [] -> 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) = @@ -672,7 +737,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) - +-} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5f5a9e61..af672ff7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -645,11 +645,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual | [] <- cons = dataHeader - | [lcon] <- cons, ResTyH98 <- resTy, + | [lcon] <- cons, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | ResTyH98 <- resTy = dataHeader + | isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) | otherwise = (dataHeader <+> keyword "where") @@ -663,7 +663,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> @@ -679,7 +681,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl where docname = tcdName dataDecl cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons + isH98 = case unLoc (head cons) of + ConDeclH98 {} -> True + ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -688,15 +692,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ _ -> keyword "where" - _ -> noHtml + | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (con_names (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] instancesBit = ppInstances links (OriginData docname) instances @@ -713,8 +715,8 @@ 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 DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of +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) args), noHtml, noHtml) @@ -727,28 +729,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> - ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) where + resTy = hsib_body (con_type con) + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ - ppForAllCon forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder summary one @@ -758,12 +747,11 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = con_qvars con + ltvs = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con) tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) + lcontext = fromMaybe (noLoc []) (con_cxt con) + context = unLoc lcontext + forall_ = False -- ppConstrHdr is for (non-GADT) existentials constructors' syntax @@ -782,11 +770,11 @@ ppConstrHdr forall_ tvs ctxt unicode qual ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L loc con) +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where - decl = case con_res con of - ResTyH98 -> case con_details con of + decl = case con of + ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) @@ -800,35 +788,25 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) ppLParendType unicode qual arg2] <+> fixity - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + ConDeclGADT{} -> doGADTCon resTy + + resTy = hsib_body (con_type con) - fieldPart = case con_details con of + fieldPart = case getConDetails con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppOcc <+> dcolon unicode - <+> ppLType unicode qual (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) + doGADTCon :: Located (HsType DocName) -> Html + doGADTCon ty = ppOcc <+> dcolon unicode + <+> ppLType unicode qual ty <+> fixity - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) - | otherwise = ty - fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ con_names con + occ = map (nameOccName . getName . unLoc) $ getConNames con ppOcc = case occ of [one] -> ppBinder False one @@ -838,15 +816,13 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con + tyVars = tyvarNames (fromMaybe (HsQTvs 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 $ con_names con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification @@ -955,24 +931,6 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAllCon :: Bool -> LHsQTyVars DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAllCon expl tvs cxt unicode qual = - forall_part <+> ppLContext cxt unicode qual - where - forall_part = ppLTyVarBndrs expl tvs unicode qual - -ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html -ppLTyVarBndrs show_forall tvs unicode _qual - | show_forall - , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode - | otherwise = noHtml - where - tv_bndrs = hsQTvBndrs tvs - ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot @@ -1005,7 +963,9 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur + -- un ConDeclGADT, but is + -- output elsewhere ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3b6657c2..f68db9bc 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -300,19 +300,21 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT noSrcSpan (synifyType WithinType res_ty) - else ResTyH98 + gadt_ty = HsIB [] [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= - \hat -> return $ noLoc $ - ConDecl { con_names = [name] - , con_explicit = Implicit -- we don't know nor care - , con_qvars = qvars - , con_cxt = ctx - , con_details = hat - , con_res = hs_res_ty - , con_doc = Nothing } + \hat -> + if use_gadt_syntax + then return $ noLoc $ + ConDeclGADT { con_names = [name] + , con_type = gadt_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 } synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index e2aa8f06..2a9fba2e 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -187,14 +187,14 @@ class Parent a where instance Parent (ConDecl Name) where children con = - case con_details con of + case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where children d - | isDataDecl d = map unL $ concatMap (con_names . unL) + | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ @@ -208,7 +208,7 @@ family = getName &&& children familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) +familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5ce4e6e6..d427be6c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -50,6 +50,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..) ) import qualified Outputable as O +import HsDecls ( gadtDeclDetails,getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -340,9 +341,9 @@ subordinates instMap decl = case decl of where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- con_names c ] + | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons + | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] @@ -797,7 +798,8 @@ extractDecl name mdl decl SigD <$> extractRecSel name mdl n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -812,7 +814,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of + 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))))) _ -> extractRecSel nm mdl t tvs rest @@ -821,7 +823,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) = matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty - | ResTyGADT _ ty <- con_res con = ty + -- | ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = hsib_body $ con_type con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2183d8f2..378dcf61 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -411,17 +411,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars - lcontext' <- renameLContext lcontext +renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- traverse renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext details' <- renameDetails details - restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_doc = mbldoc' }) where renameDetails (RecCon (L l fields)) = do @@ -433,9 +432,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars b' <- renameLType b return (InfixCon a' b') - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t - +renameCon decl@(ConDeclGADT { con_names = lnames + , con_type = lty + , con_doc = mbldoc }) = do + lnames' <- mapM renameL lnames + lty' <- renameLSigType lty + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_names = lnames' + , con_type = lty', con_doc = mbldoc' }) renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) renameConDeclFieldField (L l (ConDeclField names t doc)) = do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 658007ba..45deca9c 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -180,18 +180,32 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = - case con_details d of + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case getConDetails h98d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (h98d { con_details = 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 Name + c' = ConDeclH98 + { con_name = head (con_names c) + , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_cxt = Just cxt + , con_details = details + , con_doc = con_doc c + } + field_avail :: LConDeclField Name -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs -- cgit v1.2.3 From cc20c0da2a9d8065e9d2f2470725e41353767214 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 5 Dec 2015 19:45:33 +0200 Subject: Placeholder for record style GADT declaration A GADT Declaration is now presented as CmmCondBranch :: {..} -> CmmNode O C cml_pred :: CmmExpr cml_true, cml_false :: !Label cml_likely :: Maybe Bool for CmmCondBranch :: { -- conditional branch cml_pred :: CmmExpr, cml_true, cml_false :: ULabel, cml_likely :: Maybe Bool -- likely result of the conditional, -- if known } -> CmmNode O C --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index af672ff7..0e5e381a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -801,6 +801,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT <+> ppLType unicode qual ty <+> fixity @@ -963,9 +964,10 @@ ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TO ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = mempty -- Can now legally occur - -- un ConDeclGADT, but is - -- output elsewhere +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 _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -- cgit v1.2.3 From 50c0faf18a5c963c0df874aa94b034430280856a Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 8 Dec 2015 23:54:34 -0500 Subject: Update for type=kinds --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 14 +++---- haddock-api/src/Haddock/Convert.hs | 43 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 24 ++++++++---- haddock-api/src/Haddock/Interface/Rename.hs | 12 +++--- haddock-api/src/Haddock/Utils.hs | 8 ++-- 7 files changed, 62 insertions(+), 50 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index cef0da20..a8882fe2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -242,7 +242,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} name = commaSeparate dflags . map unL $ getConNames con resType = apps $ map (reL . HsTyVar . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e7780d6e..75a4edba 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -413,7 +413,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName) tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -725,7 +725,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + 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) @@ -957,7 +957,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -967,7 +966,7 @@ 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 +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where @@ -987,6 +986,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0e5e381a..124debfb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html] ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvBndrs ltyvars)) + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -969,11 +969,9 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = - promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = - promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) 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 $ @@ -983,7 +981,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f68db9bc..664598ab 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,19 +26,19 @@ import Data.List( partition ) import DataCon import FamInstEnv import HsSyn -import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) -import Util ( filterByList ) +import Util ( filterByList, filterOut ) import Var import Haddock.Types @@ -117,11 +117,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats - , hsib_kvs = map tyVarName kvs - , hsib_tvs = map tyVarName tvs } + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -149,8 +147,8 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -188,11 +186,12 @@ synifyTyCon _coax tc , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) + synifyFamilyResultSig resultVar tyConResKind , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) (familyTyConInjectivityInfo tc) } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc @@ -300,7 +299,7 @@ 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) + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> @@ -329,10 +328,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } - where - (kvs, tvs) = partition isKindVar ktvs +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv @@ -387,19 +384,21 @@ synifyType _ (TyConApp tc tys) , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) (noLoc $ HsTyVar $ noLoc (getName tc)) - (map (synifyType WithinType) tys) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +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 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 @@ -414,6 +413,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -437,7 +438,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead } } where - (ks,ts) = break (not . isKind) types + (ks,ts) = partitionInvisibles (classTyCon cls) id types synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family @@ -456,5 +457,5 @@ synifyFamInst fi opaque = do return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = break (not . isKind) $ fi_tys fi + (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 21569374..56382341 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -42,7 +43,7 @@ import SrcLoc import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -160,18 +161,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -221,9 +230,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 378dcf61..e3a5a7d5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -234,11 +234,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -254,18 +254,18 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -547,7 +547,7 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } + , hsib_vars = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 45deca9c..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) - | tv <- hsQTvBndrs tvs ] + | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- * Making abstract declarations @@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] c' :: ConDecl Name c' = ConDeclH98 { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } , con_cxt = Just cxt , con_details = details , con_doc = con_doc c @@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3 From cb89336401b74b274b81b28079e6906e926409c4 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 14 Dec 2015 18:17:00 +0000 Subject: Changes to compile with 8.0 --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 +-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 24 ++++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 24 ++++--- haddock-api/src/Haddock/Convert.hs | 12 +--- haddock-api/src/Haddock/Interface/Rename.hs | 4 +- haddock-api/src/Haddock/Interface/Specialize.hs | 78 +++++++++++----------- haddock-api/src/Haddock/Types.hs | 10 +-- 8 files changed, 82 insertions(+), 82 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index ef873500..70cdf8a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -269,7 +269,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) - pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap + pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap pkgSrcMap' | Flag_HyperlinkedSource `elem` flags = Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index a8882fe2..1adcddfc 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) - f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ) + 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 ++ ppFixities f _ = [] @@ -157,10 +157,10 @@ ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where - ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl - ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext + ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl + ppSig' = flip (ppSigWithDoc dflags) subdocs - add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x) + add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl) ppTyFams | null $ tcdATs decl = "" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 5eca973e..060534bf 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where @@ -10,6 +11,7 @@ import Haddock.Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified FieldLabel as GHC import Control.Applicative import Data.Data @@ -56,8 +58,8 @@ variables = where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> - pure (sspan, RtkVar name) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) -> + pure (sspan, RtkVar (GHC.unLoc name)) + (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of @@ -72,7 +74,7 @@ types = where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar name))) -> - pure (sspan, RtkType name) + pure (sspan, RtkType (GHC.unLoc name)) _ -> empty -- | Obtain details map for identifier bindings. @@ -85,12 +87,12 @@ binds = everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> - pure (sspan, RtkBind name) + pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> @@ -102,7 +104,7 @@ binds = _ -> empty tvar term = case cast term of (Just (GHC.L sspan (GHC.UserTyVar name))) -> - pure (sspan, RtkBind name) + pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -121,7 +123,7 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -134,9 +136,10 @@ decls (group, _, _, _) = concatMap ($ group) pure . tyref $ GHC.tfe_tycon eqn _ -> empty fld term = case cast term of - Just field -> map decl $ GHC.cd_fld_names field + Just (field :: GHC.ConDeclField GHC.Name) + -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names + sig (GHC.L _ (GHC.TypeSig names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -153,7 +156,8 @@ imports src@(_, imps, _, _) = (Just (GHC.IEVar v)) -> pure $ var v (Just (GHC.IEThingAbs t)) -> pure $ typ t (Just (GHC.IEThingAll t)) -> pure $ typ t - (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs + (Just (GHC.IEThingWith t _ vs _fls)) -> + [typ t] ++ map var vs _ -> 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/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 124debfb..ae1905bf 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -270,24 +270,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ) <+> ppFamDeclBinderWithVars summary d <+> - - (case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - ) <+> + ppResultSig result unicode qual <+> (case injectivity of Nothing -> noHtml Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn ) +ppResultSig :: FamilyResultSig DocName -> 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 + ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppFamilyInfo True pfdInfo <+> ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> - ppFamilyKind unicode qual pfdKindSig + ppResultSig (unLoc pfdKindSig) unicode qual ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = @@ -530,7 +531,7 @@ ppClassDecl summary links instances fixities loc d subdocs 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 | TypeSig ns _ _ <- sigs, L _ n <- ns] + sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method @@ -612,9 +613,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocName] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames (L loc typ) _ <- sigs + TypeSig lnames typ <- sigs let names = map unLoc lnames - return $ ppSimpleSig links splice unicode qual loc names typ + L loc rtyp = get_type typ + return $ ppSimpleSig links splice unicode qual loc names rtyp + where + get_type = hswc_body . hsib_body lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 664598ab..4a7ad162 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -100,14 +100,8 @@ tyThingToLHsDecl t = case t of (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps - qtvs = univ_tvs ++ ex_tvs - ty = mkFunTys arg_tys res_ty - in allOK . SigD $ PatSynSig (synifyName ps) - (Implicit, synifyTyVars qtvs) - (synifyCtx req_theta) - (synifyCtx prov_theta) - (synifyType WithinType ty) + allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType + (patSynType ps)) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -457,5 +451,5 @@ synifyFamInst fi opaque = do return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi + (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index e3a5a7d5..859afe6e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -294,7 +294,7 @@ renameInstHead InstHead {..} = do itype <- case ihdInstType of ClassInst { .. } -> ClassInst <$> mapM renameType clsiCtx - <*> renameLTyVarBndrs clsiTyVars + <*> renameLHsQTyVars clsiTyVars <*> mapM renameSig clsiSigs <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts @@ -390,7 +390,7 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo <*> renameL pfdLName <*> mapM renameLType pfdTyVars - <*> renameMaybeLKind pfdKindSig + <*> renameFamilyResultSig pfdKindSig renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index d6466570..e9b9c60a 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name) specialize name details = everywhere $ mkT step where - step (HsTyVar name') | name == name' = details + step (HsTyVar (L _ name')) | name == name' = details step typ = typ @@ -56,18 +56,18 @@ specialize' = flip $ foldr (uncurry specialize) -- length of type list should be the same as the number of binders. specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) => Data a - => LHsTyVarBndrs name -> [HsType name] + => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs = specialize' $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs - bname (UserTyVar name) = name + bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs + bname (UserTyVar (L _ name)) = name bname (KindedTyVar (L _ name) _) = name specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) - => LHsTyVarBndrs name -> [HsType name] + => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = @@ -76,14 +76,17 @@ specializePseudoFamilyDecl bndrs typs decl = specializeTyVars = specializeTyVarBndrs bndrs typs -specializeSig :: (Eq name, Typeable name, DataId name, SetName name) - => LHsTyVarBndrs name -> [HsType name] +specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name) + => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name -specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = - TypeSig lnames (L loc typ') prn +specializeSig bndrs typs (TypeSig lnames typ) = + TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) where - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ + true_type :: HsType name + true_type = unLoc (hswc_body (hsib_body typ)) + typ' :: HsType name + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -120,7 +123,7 @@ sugar = sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) +sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name @@ -134,7 +137,7 @@ sugarTuples typ = where aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar name) + aux apps (HsTyVar (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name @@ -146,8 +149,8 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb) - | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb +sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb) + | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb where name' = getName name @@ -219,13 +222,13 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy _ _ bndrs _ _) -> + Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar name) + Just (HsTyVar (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) -- | Make given type visually unambiguous. @@ -256,26 +259,26 @@ data RenameEnv name = RenameEnv renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> +renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> HsForAllTy - <$> pure ex - <*> pure mspan - <*> pure lbndrs' - <*> located renameContext lctx + <$> pure bndrs' <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> renameName name +renameType (HsQualTy lctxt lt) = + HsQualTy + <$> located renameContext lctxt + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> 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 (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType 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 t@(HsQuasiQuoteTy _) = pure t renameType t@(HsSpliceTy _ _) = pure t renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt @@ -286,9 +289,7 @@ renameType (HsExplicitListTy ph ltys) = renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t -renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t -renameType HsWildcardTy = pure HsWildcardTy -renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name +renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameLType :: SetName name => LHsType name -> Rename name (LHsType name) @@ -302,21 +303,20 @@ renameLTypes = mapM renameLType renameContext :: SetName name => HsContext name -> Rename name (HsContext name) renameContext = renameLTypes - +{- renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname +-} renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { rneCtx = ctx } <- ask - pure $ case Map.lookup (getName name) ctx of - Just name' -> name' - Nothing -> name + pure $ fromMaybe name (Map.lookup (getName name) ctx) rebind :: SetName name - => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a) + => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) -> Rename name a rebind lbndrs action = do (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask @@ -324,16 +324,14 @@ rebind lbndrs action = do rebindLTyVarBndrs :: SetName name - => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) -rebindLTyVarBndrs lbndrs = do - tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs - pure $ lbndrs { hsq_tvs = tys' } + => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] +rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs rebindTyVarBndr :: SetName name => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar name) = - UserTyVar <$> rebindName name +rebindTyVarBndr (UserTyVar (L l name)) = + UserTyVar . L l <$> rebindName name rebindTyVarBndr (KindedTyVar name kinds) = KindedTyVar <$> located rebindName name <*> pure kinds @@ -403,5 +401,5 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> name -tyVarName (UserTyVar name) = name +tyVarName (UserTyVar name) = unLoc name tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e07f55f1..6bc00f63 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -326,7 +326,7 @@ instance SetName DocName where data InstType name = ClassInst { clsiCtx :: [HsType name] - , clsiTyVars :: LHsTyVarBndrs name + , clsiTyVars :: LHsQTyVars name , clsiSigs :: [Sig name] , clsiAssocTys :: [PseudoFamilyDecl name] } @@ -353,7 +353,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name , pfdLName :: Located name , pfdTyVars :: [LHsType name] - , pfdKindSig :: Maybe (LHsKind name) + , pfdKindSig :: LFamilyResultSig name } @@ -361,14 +361,14 @@ mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName - , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ] - , pfdKindSig = fdKindSig + , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ] + , pfdKindSig = fdResultSig } where mkType (KindedTyVar (L loc name) lkind) = HsKindSig tvar lkind where - tvar = L loc (HsTyVar name) + tvar = L loc (HsTyVar (L loc name)) mkType (UserTyVar name) = HsTyVar name -- cgit v1.2.3 From a89c8083c2c08d9cd9607a91d6ea11420bd72a70 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Mon, 14 Dec 2015 18:47:12 +0000 Subject: Warnings --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 -- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 1 - haddock-api/src/Haddock/Backends/LaTeX.hs | 3 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 9 +-------- haddock-api/src/Haddock/Convert.hs | 3 +-- haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 -- haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 - haddock-api/src/Haddock/Interface/Specialize.hs | 11 ++++++----- 8 files changed, 9 insertions(+), 23 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1adcddfc..a9bc9a8b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -21,7 +21,6 @@ import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) -import Bag import GHC import Outputable import NameSet @@ -140,7 +139,6 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - typ = unL (hsSigWcType sig) ppSigWithDoc _ _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 060534bf..1f396df5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -11,7 +11,6 @@ import Haddock.Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC -import qualified FieldLabel as GHC import Control.Applicative import Data.Data diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 75a4edba..ab6bb41c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -25,10 +25,9 @@ import qualified Pretty import GHC import OccName import Name ( nameOccName ) -import RdrName ( rdrNameOcc, mkRdrUnqual ) +import RdrName ( rdrNameOcc ) import FastString ( unpackFS, unpackLitString, zString ) import Outputable ( panic) -import PrelNames ( mkUnboundName ) import qualified Data.Map as Map import System.Directory diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ae1905bf..d27cb2bc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -38,8 +38,7 @@ import GHC import GHC.Exts import Name import BooleanFormula -import RdrName ( rdrNameOcc, mkRdrUnqual ) -import PrelNames ( mkUnboundName ) +import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] @@ -246,12 +245,6 @@ ppFamilyInfo assoc DataFamily ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" -ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html -ppFamilyKind unicode qual (Just kind) = - dcolon unicode <+> ppLKind unicode qual kind -ppFamilyKind _ _ Nothing = noHtml - - ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4a7ad162..bc293731 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,14 +22,13 @@ import Class import CoAxiom import ConLike import Data.Either (lefts, rights) -import Data.List( partition ) import DataCon import FamInstEnv import HsSyn import Name import RdrName ( mkVarUnqual ) import PatSyn -import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) +import SrcLoc ( Located, noLoc, unLoc ) import TcType ( tcSplitSigmaTy ) import TyCon import Type diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 56382341..faf043aa 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -33,7 +33,6 @@ import FamInstEnv import FastString import GHC import GhcMonad (withSession) -import Id import InstEnv import MonadUtils (liftIO) import Name @@ -41,7 +40,6 @@ import Outputable (text, sep, (<+>)) import PrelNames import SrcLoc import TcRnDriver (tcRnGetInfo) -import TcType (tcSplitSigmaTy) import TyCon import TyCoRep import TysPrim( funTyCon ) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 0f6add36..661bd6be 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -28,7 +28,6 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name -import RdrHsSyn ( setRdrNameSpace ) import Outputable ( showPpr ) import RdrName import RnEnv (dataTcOccs) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index e9b9c60a..ab719fe8 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -54,7 +54,7 @@ specialize' = flip $ foldr (uncurry specialize) -- -- 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 :: (Eq name, Typeable name, DataId name) +specializeTyVarBndrs :: (Eq name, DataId name) => Data a => LHsQTyVars name -> [HsType name] -> a -> a @@ -66,7 +66,7 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) +specializePseudoFamilyDecl :: (Eq name, DataId name) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name @@ -76,7 +76,7 @@ specializePseudoFamilyDecl bndrs typs decl = specializeTyVars = specializeTyVarBndrs bndrs typs -specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name) +specializeSig :: forall name . (Eq name, DataId name, SetName name) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name @@ -93,7 +93,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name) +specializeInstHead :: (Eq name, DataId name, SetName name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -149,7 +149,7 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb) +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 where @@ -290,6 +290,7 @@ renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" renameLType :: SetName name => LHsType name -> Rename name (LHsType name) -- cgit v1.2.3 From d4657f07912416a1b14ddb517696f8ef3ffb85a7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 12 Dec 2015 17:20:15 +0100 Subject: Update for D1200 --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Interface/LexParseRn.hs | 5 +++-- haddock-api/src/Haddock/Types.hs | 5 +++-- haddock.cabal | 1 + 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index dc3e8c69..292965bf 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -45,6 +45,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 + , ghc-boot , ghc == 7.9.* , ghc-paths diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index ac823da3..9c46c700 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,8 @@ import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) +import DynFlags (languageExtensions) +import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader @@ -65,7 +66,7 @@ processModuleHeader dflags gre safety mayStr = do doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag] + let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index f667b52c..6305dba1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -31,7 +31,8 @@ import qualified Data.Map as Map import Documentation.Haddock.Types import BasicTypes (Fixity(..)) import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) +import DynFlags (Language) +import qualified GHC.LanguageExtensions as LangExt import OccName import Outputable import NameSet (NameSet) @@ -400,7 +401,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] + , hmi_extensions :: [LangExt.Extension] } diff --git a/haddock.cabal b/haddock.cabal index 56e62e60..dc331b2f 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -57,6 +57,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, + ghc-boot, ghc >= 7.11 && < 7.13, bytestring, transformers -- cgit v1.2.3 From 91217a9642962476a736f6179d0803ddb787c2b9 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 05:40:17 -0500 Subject: Types: Add Outputable[Bndr] DocName instances --- haddock-api/src/Haddock/Types.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6305dba1..6f9b64dd 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -286,6 +286,14 @@ instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging +instance Outputable DocName where + ppr = ppr . getName + +instance OutputableBndr DocName where + pprBndr _ = ppr . getName + pprPrefixOcc = pprPrefixOcc . getName + pprInfixOcc = pprInfixOcc . getName ----------------------------------------------------------------------------- -- * Instances -- cgit v1.2.3 From 66cf3d2714ef1cf851782fbe4378f8c2b1af3335 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 06:05:25 -0500 Subject: Fix fallout from wildcards refactoring The wildcard refactoring was introduced a new type of signature, `ClassOpSig`, which is carried by typeclasses. The original patch adapting Haddock for this change missed a few places where this constructor needed to be handled, resulting in no class methods in documentation produced by Haddock. Additionally, this moves and renames the `isVanillaLSig` helper from GHC's HsBinds module into GhcUtils, since it is only used by Haddock. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/GhcUtils.hs | 18 ++++++++++++++---- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++++ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0b5a3356..d54f4e16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -412,7 +412,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -451,7 +451,7 @@ ppClassDecl summary links instances fixities loc d subdocs +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index ab4d6c78..2fbc5f82 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -96,6 +96,10 @@ filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -106,13 +110,19 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] +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 +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 30b32963..7da965ac 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -396,7 +396,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -428,7 +428,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -441,7 +441,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 845cb909..091d9bff 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -441,6 +441,10 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') PatSynSig lname sig_ty -> do lname' <- renameL lname sig_ty' <- renameLSigType sig_ty -- cgit v1.2.3 From 85be6fdc7832eae3afd141229c8ac3475da8f542 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 12 Dec 2015 17:20:15 +0100 Subject: Update for D1200 --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Interface/LexParseRn.hs | 5 +++-- haddock-api/src/Haddock/Types.hs | 5 +++-- haddock.cabal | 1 + 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 26bb1d94..7835ea50 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -48,6 +48,7 @@ library , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10 + , ghc-boot , ghc >= 7.10 && < 7.12 , ghc-paths diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 661bd6be..3c14498c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -21,7 +21,8 @@ module Haddock.Interface.LexParseRn import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (ExtensionFlag(..), languageExtensions) +import DynFlags (languageExtensions) +import qualified GHC.LanguageExtensions as LangExt import FastString import GHC import Haddock.Interface.ParseModuleHeader @@ -64,7 +65,7 @@ processModuleHeader dflags gre safety mayStr = do doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') - let flags :: [ExtensionFlag] + let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6bc00f63..914f00f2 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -33,7 +33,8 @@ import Documentation.Haddock.Types import BasicTypes (Fixity(..)) import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) +import DynFlags (Language) +import qualified GHC.LanguageExtensions as LangExt import Coercion import NameSet import OccName @@ -494,7 +495,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_safety :: Maybe String , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] + , hmi_extensions :: [LangExt.Extension] } diff --git a/haddock.cabal b/haddock.cabal index 55af3c05..ec2a43bc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -59,6 +59,7 @@ executable haddock array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, + ghc-boot, ghc >= 7.11 && < 7.13, bytestring, transformers -- cgit v1.2.3 From a45a133af1f25ce60a8d1b0750c8f3ce452129d6 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 05:40:17 -0500 Subject: Types: Add Outputable[Bndr] DocName instances --- haddock-api/src/Haddock/Types.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 914f00f2..b837970b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -301,6 +301,14 @@ instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name +-- | Useful for debugging +instance Outputable DocName where + ppr = ppr . getName + +instance OutputableBndr DocName where + pprBndr _ = ppr . getName + pprPrefixOcc = pprPrefixOcc . getName + pprInfixOcc = pprInfixOcc . getName class NamedThing name => SetName name where -- cgit v1.2.3 From 3de72a80fff18aa71873ace86d1aeb5171b09b41 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 06:05:25 -0500 Subject: Fix fallout from wildcards refactoring The wildcard refactoring was introduced a new type of signature, `ClassOpSig`, which is carried by typeclasses. The original patch adapting Haddock for this change missed a few places where this constructor needed to be handled, resulting in no class methods in documentation produced by Haddock. Additionally, this moves and renames the `isVanillaLSig` helper from GHC's HsBinds module into GhcUtils, since it is only used by Haddock. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/GhcUtils.hs | 18 ++++++++++++++---- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++++ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d27cb2bc..49149b8c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -451,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -492,7 +492,7 @@ ppClassDecl summary links instances fixities loc d subdocs sigs = map unLoc lsigs classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 2a9fba2e..4e5e008b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -95,6 +95,10 @@ filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -105,13 +109,19 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _) = [unLoc n] +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 +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d427be6c..c41946f5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -402,7 +402,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -434,7 +434,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -447,7 +447,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 859afe6e..2478ce23 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -459,6 +459,10 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') PatSynSig lname sig_ty -> do lname' <- renameL lname sig_ty' <- renameLSigType sig_ty -- cgit v1.2.3 From fa03f80d76f1511a811a0209ea7a6a8b6c58704f Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 16 Dec 2015 23:32:38 +0100 Subject: Fix Hyperlinker GHC.con_names is now GHC.getConNames --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 1f396df5..e8baae88 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -127,7 +127,7 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty con term = case cast term of (Just cdcl) -> - map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl + map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl Nothing -> empty ins term = case cast term of (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst -- cgit v1.2.3
    SomeNewTypeConst String

    newtype SomeOtherNewType

    SomeOtherNewTypeConst String

    Produced by Haddock version 2.15.0

    version 2.16.2

    Re-exported from an other module

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data Foo

    Produced by Haddock version 2.15.0

    version 2.16.2

    data family SomeTypeFamily k :: * -> *

    data family SomeOtherTypeFamily k :: * -> *

    Produced by Haddock version 2.16.0

    version 2.16.2

    type TypeSyn = String

    type OtherTypeSyn = String

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    fib :: Integer

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foobar :: t

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f

    g

    h

    i

    j

    Produced by Haddock version 2.15.0

    version 2.16.2

    data H1 a b where

    Foo

    Fields

    fooName :: String

    some name

    fooValue :: Int
  • fooValue :: Int

    Deprecated: do not use this

    some value

    • Produced by Haddock version 2.15.0

    version 2.16.2

    data HashTable key val

    s

    new :: (Eq

    insert :: (Eq

    lookup :: Hash

    class Hash a where

    Methods

    hash :: a -> Int

    Produced by Haddock version 2.16.1

    version 2.16.2

    class VisibleClass a

    data VisibleData

    Produced by Haddock version 2.16.1

    version 2.16.2

    class Foo a

    data Bar

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    bar :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    data X

    C1 :: H1
    C2 :: Ord
    C3 :: Int

    Fields

    field :: Int

    hello docs

    C4 :: a -> H1

    Fields

    field2 :: a

    hello2 docs

    X

    c :: (?x :: X

    d :: (?x :: X

    f :: ((?x :: X

    Produced by Haddock version 2.15.0

    version 2.16.2

    class Foo a where

    Methods

    foo :: a

    Any two of these are required...

    bar :: a

    bat :: a

    fooBarBat :: (a, a, a)

    class Weird a where

    Methods

    a :: a

    b :: a

    c :: a

    d :: a

    e :: a

    f :: a

    g :: a

    class NoMins a where

    Methods

    x :: a

    y :: a

    z :: a

    class FullMin a where

    Methods

    aaa :: a

    bbb :: a

    class PartialMin a where

    Methods

    ccc :: a

    class EmptyMin a where

    Methods

    eee :: a

    fff :: a

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    d :: t

    e :: t

    f :: t

    g :: t

    h :: t

    i :: t

    j :: t

    k :: t

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    g :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f :: a

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    (+-) :: a -> a -> a

    (*/) :: a -> a -> a infixr 7

    foo :: a -> a -> a infixl 3

    data Foo

    		Foo `Bar` FooFoo :- Foo

    pattern (:+) :: t -> t -> [t] infixr 3

    data a a <-> b where
    (:<->) :: a -> b -> a <->

    type family a a ++ b infix 3

    data family a a ** b infix 9

    class a a ><> b where

    type a a <>< b :: * infixl 2

    data a a ><< b infixl 3

    Methods

    (>><), , (<<>) :: a -> b -> () infixl 5 <<>

    (**>), , (**<), , (>**), , (<**) :: a -> a -> () infixr 8 **>, >**

    type (>-<) a b = a <->

    Produced by Haddock version 2.16.0

    version 2.16.2

    data FooType x

    FooCtor x

    pattern Foo :: t -> FooType

    pattern Bar :: t -> FooType

    pattern (:<->) :: t -> t -> (FooType

    data a a >< b

    Doc for (><><)

    Empty

    pattern E :: (><)

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    fib :: Integer

    Produced by Haddock version 2.15.0

    version 2.16.2

    Produced by Haddock version 2.15.0

    version 2.16.2

    data Expr

    IntExpr Integer
    AntiIntExpr String
    BinopExpr BinOp
    AntiExpr String

    data BinOp

    AddOp
    SubOp
    MulOp
    DivOp

    eval :: Expr

    expr :: QuasiQuoter

    parseExprExp :: String

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    val :: Integer

    Produced by Haddock version 2.15.0

    version 2.16.2

    data SomeType f a

    Produced by Haddock version 2.16.1

    version 2.16.2

    Documentation

    decl :: Q [Dec]

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    f :: t -> t

    Produced by Haddock version 2.15.0

    version 2.16.2

    data T a b

    A Int
    B (T

    data T2 a b

    data T3 a b

    A1 a
    B1 b

    data T4 a b

    A2 a
    B2 b

    data T5 a b

    A3 a
    B3 b

    data T6

    A4
    B4
    C4

    newtype N1 a

    N1 a

    newtype N2 a b

    newtype N3 a b

    N2

    Fields

    n :: a b
     
    • n :: a b
       

    data N4 a b

    newtype N5 a b

    N3

    Fields

    n3 :: a b

    this is the n3 field

    • n3 :: a b

      this is the n3 field

    newtype N6 a b

    N5

    Fields

    n5 :: a b

    no docs on the datatype or the constructor

    • n5 :: a b

      no docs on the datatype or the constructor

    newtype N7 a b

    N6

    Fields

    n6 :: a b
     
    • n6 :: a b
       

    data R

    N7

    Fields

    n7 :: a b
     
    • n7 :: a b
       

    data R1

    C1

    Fields

    p :: Int

    This comment applies to the p field

    q :: forall a. a -> a

    This comment applies to the q field

    r, s :: Int

    This comment applies to both r and s

    • p :: Int

      This comment applies to the p field

    • q :: forall a. a -> a

      This comment applies to the q field

    • r, s :: Int

      This comment applies to both r and s

    C2

    Fields

    t :: T1 -> T2 Int Int -> T3 Bool Bool -> T4 Float Float -> T5 () ()
     
    u, v :: Int
     
    classD a => a => C a where

    Methods

    a :: IO method

    b :: [a]

    class D a where

    Methods

    d :: T a b

    e :: (a, a)

    class E a

    class F a where

    Methods

    ff :: a

    Function types

    f :: C

    g :: IntA hidden module

    hidden :: Int

    data Ex a

    forall b . C b => b => Ex1 b
    C3

    Fields

    s1 :: Int

    The s1 record selector

    s2 :: Int

    The s2 record selector

    s3 :: Int

    The s3 record selector

    forall b . b . Ex2 bforall b . C a => a => Ex3 b
    Ex4 (forallType signatures with argument docs

    k

    l

    m

    o

    f' :: Int

    withType :: Int

    withoutType :: t

    Produced by Haddock version 2.16.1

    version 2.16.2

    Synopsis

    Documentation

    f :: :: Integer

    Documentation

    f :: a

    Produced by Haddock version 2.15.0

    version 2.16.2

    class C a where

    Methods

    f :: a

    Produced by Haddock version 2.15.0

    version 2.16.2

    data a a :- b

    Q

    f :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    foo :: Integer

    bar :: Integer

    Produced by Haddock version 2.15.0

    version 2.16.2

    data X

    X
    X
    XX
    XXXAssocD * X = = AssocX

    type family Foo a

    data family Bar a

    Bar W = = BarX Z

    Produced by Haddock version 2.16.1

    version 2.16.2

    data a a :-: b

    data (a (a :+: b) c

    data Op a b

    newtype O g f a

    ZA
    ZBwhere

    class a a <=> b

    biO :: (g `O`

    f :: (a ~ b) => a -> b

    g :: (a ~ b, b ~ c) => a -> c

    x :: (a :-:

    y :: (a <=>

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    x :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    Documentation

    visible :: Int

    Produced by Haddock version 2.15.0

    version 2.16.2

    g

    h

    i

    j

    .doc { + display: table-cell; padding-left: 0.5em; margin-bottom: 0.5em; } -.subs dd.empty { - display: none; -} - -.subs dd p { +.subs ul li > .doc p { margin: 0; } -- cgit v1.2.3 From acdbdc035468374cbea2ba2043987dac95c44bfe Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 20:54:59 +0200 Subject: Fix quote syntax for promoted types. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 ++++-- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 7 ++++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index df85a492..d3900f16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -874,8 +874,10 @@ ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = + promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = + promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 26bcbf6d..98ff4007 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -21,7 +21,7 @@ module Haddock.Backends.Xhtml.Utils ( keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, hsep, vcat, @@ -150,6 +150,11 @@ quote :: Html -> Html quote h = char '`' +++ h +++ '`' +-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@). +promoQuote :: Html -> Html +promoQuote h = char '\'' +++ h + + parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' -- cgit v1.2.3 From 33fe6286907592b1783a4b9b7c4b7f63ae080cde Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 21:12:00 +0200 Subject: Apply promoted type quoting to type-level consing. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d3900f16..5f6f60eb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -892,7 +892,12 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = ppLDocName qual Infix op + -- `(:)` is valid in type signature only as constructor to promoted list + -- and needs to be quoted in code so we explicitly quote it here too. + ppr_op + | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | otherwise = ppr_op' + ppr_op' = ppLDocName qual Infix op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) -- cgit v1.2.3 From 3ad8ada0ea2982ba7974e381f07e84c35c9559af Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 21:17:10 +0200 Subject: Extend advanced types test case with other examples. --- html-test/src/AdvanceTypes.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/html-test/src/AdvanceTypes.hs b/html-test/src/AdvanceTypes.hs index 939fdf07..c89d7396 100644 --- a/html-test/src/AdvanceTypes.hs +++ b/html-test/src/AdvanceTypes.hs @@ -4,6 +4,20 @@ {-# LANGUAGE TypeOperators #-} module AdvanceTypes where + +data RevList a = RNil | RevList a :> a + + data Pattern :: [*] -> * where Nil :: Pattern '[] Cons :: Maybe h -> Pattern t -> Pattern (h ': t) + + +-- Unlike (:), (:>) does not have to be quoted on type level. +data RevPattern :: RevList * -> * where + RevNil :: RevPattern RNil + RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h) + + +data Tuple :: (*, *) -> * where + Tuple :: a -> b -> Tuple '(a, b) -- cgit v1.2.3 From 66c91a3c20d18f2a2f9ccfbbc7a04bddd5507008 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 21:22:06 +0200 Subject: Rename advanced types test case and accept new output. --- html-test/ref/AdvanceTypes.html | 97 ------------------- html-test/ref/PromotedTypes.html | 201 +++++++++++++++++++++++++++++++++++++++ html-test/src/AdvanceTypes.hs | 23 ----- html-test/src/PromotedTypes.hs | 25 +++++ 4 files changed, 226 insertions(+), 120 deletions(-) delete mode 100644 html-test/ref/AdvanceTypes.html create mode 100644 html-test/ref/PromotedTypes.html delete mode 100644 html-test/src/AdvanceTypes.hs create mode 100644 html-test/src/PromotedTypes.hs diff --git a/html-test/ref/AdvanceTypes.html b/html-test/ref/AdvanceTypes.html deleted file mode 100644 index f608efea..00000000 --- a/html-test/ref/AdvanceTypes.html +++ /dev/null @@ -1,97 +0,0 @@ - -AdvanceTypes
    O

    Fields

    unO :: g (f a)
     
    • unO :: g (f a)
       
    Safe HaskellSafe

    AdvanceTypes

    Documentation

    data Pattern :: [*] -> * where

    Constructors

    Nil :: Pattern [] 
    Cons :: Maybe h -> Pattern t -> Pattern (h : t) 
    diff --git a/html-test/ref/PromotedTypes.html b/html-test/ref/PromotedTypes.html new file mode 100644 index 00000000..db42f637 --- /dev/null +++ b/html-test/ref/PromotedTypes.html @@ -0,0 +1,201 @@ + +PromotedTypes
    Safe HaskellSafe

    PromotedTypes

    Documentation

    data RevList a

    Constructors

    RNil 
    (RevList a) :> a 

    data Pattern :: [*] -> * where

    Constructors

    Nil :: Pattern '[] 
    Cons :: Maybe h -> Pattern t -> Pattern (h ': t) 

    data RevPattern :: RevList * -> * where

    Constructors

    RevNil :: RevPattern RNil 
    RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h) 

    data Tuple :: (*, *) -> * where

    Constructors

    Tuple :: a -> b -> Tuple '(a, b) 
    diff --git a/html-test/src/AdvanceTypes.hs b/html-test/src/AdvanceTypes.hs deleted file mode 100644 index c89d7396..00000000 --- a/html-test/src/AdvanceTypes.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -module AdvanceTypes where - - -data RevList a = RNil | RevList a :> a - - -data Pattern :: [*] -> * where - Nil :: Pattern '[] - Cons :: Maybe h -> Pattern t -> Pattern (h ': t) - - --- Unlike (:), (:>) does not have to be quoted on type level. -data RevPattern :: RevList * -> * where - RevNil :: RevPattern RNil - RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h) - - -data Tuple :: (*, *) -> * where - Tuple :: a -> b -> Tuple '(a, b) diff --git a/html-test/src/PromotedTypes.hs b/html-test/src/PromotedTypes.hs new file mode 100644 index 00000000..ae3ad375 --- /dev/null +++ b/html-test/src/PromotedTypes.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + + +module PromotedTypes where + + +data RevList a = RNil | RevList a :> a + + +data Pattern :: [*] -> * where + Nil :: Pattern '[] + Cons :: Maybe h -> Pattern t -> Pattern (h ': t) + + +-- Unlike (:), (:>) does not have to be quoted on type level. +data RevPattern :: RevList * -> * where + RevNil :: RevPattern RNil + RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h) + + +data Tuple :: (*, *) -> * where + Tuple :: a -> b -> Tuple '(a, b) -- cgit v1.2.3 From 62f3a12863121fa5b6c2787185e62cfa3f44bdd6 Mon Sep 17 00:00:00 2001 From: Adam Sandberg Eriksson Date: Tue, 14 Jul 2015 21:01:01 +0200 Subject: HsBang is split into HsSrcBang and HsImplBang With recent changes in GHC handling of strictness annotations in Haddock is simplified. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +--- haddock-api/src/Haddock/Convert.hs | 20 ++++++++------------ 3 files changed, 10 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d85d75da..b8558f4f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -822,9 +822,7 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -ppBang :: HsBang -> LaTeX -ppBang HsStrict = char '!' -ppBang (HsUnpack {}) = char '!' +ppBang :: HsSrcBang -> LaTeX ppBang (HsSrcBang _ _ SrcStrict) = char '!' ppBang (HsSrcBang _ _ SrcLazy) = char '~' ppBang _ = empty diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 21ef167b..b2b6f904 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -768,9 +768,7 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -ppBang :: HsBang -> Html -ppBang HsStrict = toHtml "!" -ppBang (HsUnpack {}) = toHtml "!" +ppBang :: HsSrcBang -> Html ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" ppBang _ = noHtml diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index edf91ce5..7c9040a9 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -266,18 +266,14 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict - HsStrict -> HsSrcBang Nothing SrcNoUnpack SrcStrict - HsLazy -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness - _ -> bang - in case src_bang of - (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - ) - arg_tys (dataConSrcBangs dc) + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLoc $ HsBangTy bang' tySyn) + arg_tys (dataConSrcBangs dc) + field_tys = zipWith (\field synTy -> noLoc $ ConDeclField [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys -- cgit v1.2.3 From 6a1d4a65010932a660ceacda93c8c20fb5e1399d Mon Sep 17 00:00:00 2001 From: Thomas Miedema Date: Sat, 15 Aug 2015 14:51:18 +0200 Subject: Follow changes in GHC build system --- ghc.mk | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghc.mk b/ghc.mk index a3bb834f..af2d8de3 100644 --- a/ghc.mk +++ b/ghc.mk @@ -59,9 +59,9 @@ endif .PHONY: install_utils/haddock_data install_utils/haddock_data: $(foreach i,$(sort $(dir $(utils/haddock_dist_DATA_FILES))), \ - $(call make-command,$(call INSTALL_DIR,"$(DESTDIR)$(ghclibdir)/$i"))) + $(call make-command,$(INSTALL_DIR) "$(DESTDIR)$(ghclibdir)/$i")) $(foreach i,$(utils/haddock_dist_DATA_FILES), \ - $(call make-command,$(call INSTALL_DATA,$(INSTALL_OPTS),utils/haddock/haddock-api/resources/$i,"$(DESTDIR)$(ghclibdir)/$(dir $i)"))) + $(call make-command,$(INSTALL_DATA) $(INSTALL_OPTS) utils/haddock/haddock-api/resources/$i "$(DESTDIR)$(ghclibdir)/$(dir $i)")) .PHONY: install_utils/haddock_link install_utils/haddock_link: -- cgit v1.2.3 From 81baac997afa74be86f215d830322455b879f791 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 21 Aug 2015 18:06:09 +0100 Subject: Make Travis use 7.10.2 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ab3388cf..c16b1709 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ language: haskell env: # - GHCVER=7.8.2 # - GHCVER=7.8.3 - - GHCVER=7.10.1 + - GHCVER=7.10.2 before_install: - sudo add-apt-repository -y ppa:hvr/ghc -- cgit v1.2.3 From e9d61b79faf40200d8f9806d83a05ece272cd7d3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 10 Jul 2015 11:42:18 +0200 Subject: Move SYB utilities to standalone module. --- haddock-api/haddock-api.cabal | 1 + .../src/Haddock/Backends/Hyperlinker/Ast.hs | 15 +------------ haddock-api/src/Haddock/Syb.hs | 26 ++++++++++++++++++++++ haddock.cabal | 1 + 4 files changed, 29 insertions(+), 14 deletions(-) create mode 100644 haddock-api/src/Haddock/Syb.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 4db05de8..bfdb2179 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -94,6 +94,7 @@ library Haddock.InterfaceFile Haddock.Options Haddock.GhcUtils + Haddock.Syb Haddock.Convert Paths_haddock_api diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 71b73663..5eca973e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker.Ast (enrich) where +import Haddock.Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -179,17 +180,3 @@ matches tspan (GHC.RealSrcSpan aspan) saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) matches _ _ = False - --- | Perform a query on each level of a tree. --- --- This is stolen directly from SYB package and copied here to not introduce --- additional dependencies. -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) - --- | Combine two queries into one using alternative combinator. -combine :: Alternative f => (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs new file mode 100644 index 00000000..dd7ffc1b --- /dev/null +++ b/haddock-api/src/Haddock/Syb.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Rank2Types #-} + + +module Haddock.Syb + ( everything + , combine + ) where + + +import Data.Data +import Control.Applicative + + +-- | Perform a query on each level of a tree. +-- +-- This is stolen directly from SYB package and copied here to not introduce +-- additional dependencies. +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +-- | Combine two queries into one using alternative combinator. +combine :: Alternative f => (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x diff --git a/haddock.cabal b/haddock.cabal index 27ae8967..b0c6c34f 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -116,6 +116,7 @@ executable haddock Haddock.InterfaceFile Haddock.Options Haddock.GhcUtils + Haddock.Syb Haddock.Convert else build-depends: haddock-api == 2.16.* -- cgit v1.2.3 From f7d377ee238d3b44240a4537986a7561e822f79f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 10 Jul 2015 11:49:02 +0200 Subject: Implement `everywhere` transformation in SYB module. --- haddock-api/src/Haddock/Syb.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index dd7ffc1b..3cec724e 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -2,7 +2,7 @@ module Haddock.Syb - ( everything + ( everything, everywhere , combine ) where @@ -19,6 +19,12 @@ everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) +-- | Apply transformation on each level of a tree. +-- +-- Just like 'everything', this is stolen from SYB package. +everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) +everywhere f = f . gmapT (everywhere f) + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -- cgit v1.2.3 From dc25b7099a0d54c03bdf51dfb9a4e286942d9c31 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 10 Jul 2015 12:24:12 +0200 Subject: Implement generic transformation constructor. --- haddock-api/src/Haddock/Syb.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 3cec724e..2016b74c 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -3,6 +3,7 @@ module Haddock.Syb ( everything, everywhere + , mkT , combine ) where @@ -25,6 +26,14 @@ everything k f x = foldl k (f x) (gmapQ (everything k f) x) everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) everywhere f = f . gmapT (everywhere f) +-- | Create generic transformation. +-- +-- Another function stolen from SYB package. +mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a) +mkT f = case cast f of + Just f' -> f' + Nothing -> id + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -- cgit v1.2.3 From e4740dd872d1110247557eb7b20124c22e427789 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 10 Jul 2015 16:23:15 +0200 Subject: Create simple utility module for type specialization. --- haddock-api/haddock-api.cabal | 1 + .../src/Haddock/Backends/Xhtml/Specialize.hs | 21 +++++++++++++++++++++ haddock.cabal | 1 + 3 files changed, 23 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index bfdb2179..abe5adbe 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -75,6 +75,7 @@ library Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout Haddock.Backends.Xhtml.Names + Haddock.Backends.Xhtml.Specialize Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs new file mode 100644 index 00000000..a0d64c0f --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} + + +module Haddock.Backends.Xhtml.Specialize (specialize) where + + +import Haddock.Syb + +import GHC + +import Data.Data + + +specialize :: (Eq name, Data (HsType name)) + => name -> HsType name -> HsType name -> HsType name +specialize name details = everywhere (mkT $ specialize' name details) + +specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name +specialize' name details (HsTyVar name') | name == name' = details +specialize' _ _ typ = typ + \ No newline at end of file diff --git a/haddock.cabal b/haddock.cabal index b0c6c34f..4ea2a82a 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -97,6 +97,7 @@ executable haddock Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout Haddock.Backends.Xhtml.Names + Haddock.Backends.Xhtml.Specialize Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils -- cgit v1.2.3 From 79f475a93be3de376bc264c53d2ba8eb61ffea42 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 10 Jul 2015 16:30:11 +0200 Subject: Make type of type specialization function more general. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a0d64c0f..e8e80da1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -11,11 +11,11 @@ import GHC import Data.Data -specialize :: (Eq name, Data (HsType name)) - => name -> HsType name -> HsType name -> HsType name +specialize :: (Eq name, Typeable name) + => Data a + => name -> HsType name -> a -> a specialize name details = everywhere (mkT $ specialize' name details) specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name specialize' name details (HsTyVar name') | name == name' = details specialize' _ _ typ = typ - \ No newline at end of file -- cgit v1.2.3 From 6e0fe19f52445f0a231073b3eff116924d631588 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 13 Jul 2015 19:26:45 +0200 Subject: Add basic HTML test case for checking instance specialization. --- html-test/src/Instances.hs | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 html-test/src/Instances.hs diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs new file mode 100644 index 00000000..d0d68dc3 --- /dev/null +++ b/html-test/src/Instances.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + + +module Instances where + + +class Foo f where + + foo :: f Int -> a -> f a + foo' :: f (f a) -> Int -> f (f Int) + + foo = undefined + foo' = undefined + +instance Foo Maybe +instance Foo [] +instance (Eq a, Foo f) => Foo ((,) (f a)) +instance Foo (Either a) +instance Foo ((,,) a a) + + +class Foo f => Bar f a where + + bar :: f a -> f Bool -> a + bar' :: f (f a) -> f (f (f b)) + + bar = undefined + bar' = undefined + +instance Bar Maybe Bool +instance Bar Maybe [a] +instance Bar [] (a, a) +instance Foo f => Bar (Either a) (f a) +instance Foo ((,,) a b) => Bar ((,,) a b) (a, b, a) -- cgit v1.2.3 From 92f0b1eacb2e1169dedd22df26976219c3fbc637 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 14 Jul 2015 18:03:58 +0200 Subject: Make HTML class instance printer take optional signature argument. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5f6f60eb..a5f3676e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -268,7 +268,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances links instances docname unicode qual + = ppInstances links instances Nothing docname unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -439,6 +439,8 @@ ppClassDecl summary links instances fixities loc d subdocs | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + sigs = map unLoc lsigs + classheader | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) @@ -458,7 +460,7 @@ ppClassDecl summary links instances fixities loc d subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ) _) <- lsigs + | TypeSig lnames (L _ typ) _ <- sigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -468,15 +470,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of + minimalBit = case [ s | MinimalSig _ s <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] + sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] + [getName n' | TypeSig ns _ _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -490,13 +492,16 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances links instances nm unicode qual + instancesBit = ppInstances links instances (Just sigs) nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances links instances baseName unicode qual +ppInstances :: LinksInfo + -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName + -> Unicode -> Qualification + -> Html +ppInstances links instances _ baseName unicode qual = subInstances qual instName links True (map instDecl instances) -- force Splice = True to use line URLs where @@ -581,7 +586,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances links instances docname unicode qual + instancesBit = ppInstances links instances Nothing docname unicode qual -- cgit v1.2.3 From 2070c0fa9354365e3e672f5cbee2e04d0ef1fd02 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 14 Jul 2015 19:59:08 +0200 Subject: Refactor instance head type to record instead of a meaningless tuple. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 14 ++++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 21 ++++++++---- haddock-api/src/Haddock/Convert.hs | 38 +++++++++++++--------- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 19 +++++++---- haddock-api/src/Haddock/Types.hs | 7 +++- 6 files changed, 63 insertions(+), 38 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 2febd5ae..59e5af3e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX @@ -560,12 +561,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode -ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode - <+> maybe empty (\t -> equals <+> ppType unicode t) rhs -ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = - error "data instances not supported by --latex yet" +ppInstHead unicode (InstHead {..}) = case ihdInstType of + ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ + TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs + DataInst _ -> error "data instances not supported by --latex yet" + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode + tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a5f3676e..afbbaad1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TransformListComp #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -507,15 +508,21 @@ ppInstances links instances _ baseName unicode qual where instName = getOccString $ getName baseName instDecl :: DocInstance DocName -> (SubDecl,Located DocName) - instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l) - instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual - <+> ppAppNameTypes n ks ts unicode qual - instHead (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode qual + instDecl (inst, maybeDoc,l) = + ((ppInstHead links unicode qual inst, maybeDoc, []),l) + +ppInstHead :: LinksInfo -> Unicode -> Qualification + -> InstHead DocName + -> Html +ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of + ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ + TypeInst rhs -> keyword "type" <+> typ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - instHead (n, ks, ts, DataInst dd) = keyword "data" - <+> ppAppNameTypes n ks ts unicode qual + DataInst dd -> keyword "data" <+> typ <+> ppShortDataDecl False True dd unicode qual + where + typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5cbf5f97..e51d9df7 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -390,23 +390,29 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = - ( getName cls - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , ClassInst $ map (unLoc . synifyType WithinType) preds - ) +synifyInstHead (_, preds, cls, types) = InstHead + { ihdClsName = getName cls + , ihdKinds = map (unLoc . synifyType WithinType) ks + , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdInstType = ClassInst $ map (unLoc . synifyType WithinType) preds + } where (ks,ts) = break (not . isKind) types -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) -synifyFamInst fi opaque = - let fff = case fi_flavor fi of - SynFamilyInst | opaque -> return $ TypeInst Nothing - SynFamilyInst -> - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - DataFamilyInst c -> - synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst - in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, - map (unLoc . synifyType WithinType) ts , f') - where (ks,ts) = break (not . isKind) $ fi_tys fi +synifyFamInst fi opaque = do + ityp' <- ityp $ fi_flavor fi + return InstHead + { ihdClsName = fi_fam fi + , ihdKinds = synifyTypes ks + , ihdTypes = synifyTypes ts + , ihdInstType = ityp' + } + where + ityp SynFamilyInst | opaque = return $ TypeInst Nothing + ityp SynFamilyInst = + return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + ityp (DataFamilyInst c) = + DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + (ks,ts) = break (not . isKind) $ fi_tys fi + synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index fc530507..e2fd24ee 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -108,7 +108,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location - spanName s (clsn,_,_,_) (L instL instn) = + spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = let s1 = getSrcSpan s sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL then instn diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1a559764..d222c6d2 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -261,16 +262,20 @@ renameLContext (L loc context) = do return (L loc context') renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (className, k, types, rest) = do - className' <- rename className - k' <- mapM renameType k - types' <- mapM renameType types - rest' <- case rest of +renameInstHead InstHead {..} = do + cname <- rename ihdClsName + kinds <- mapM renameType ihdKinds + types <- mapM renameType ihdTypes + itype <- case ihdInstType of ClassInst cs -> ClassInst <$> mapM renameType cs TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd - return (className', k', types', rest') - + return InstHead + { ihdClsName = cname + , ihdKinds = kinds + , ihdTypes = types + , ihdInstType = itype + } renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6dd64506..d9ae6cab 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -308,7 +308,12 @@ type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type -type InstHead name = (name, [HsType name], [HsType name], InstType name) +data InstHead name = InstHead + { ihdClsName :: name + , ihdKinds :: [HsType name] + , ihdTypes :: [HsType name] + , ihdInstType :: InstType name + } ----------------------------------------------------------------------------- -- * Documentation comments -- cgit v1.2.3 From 05f35d7defbf702e27211628e26a738fa97ecde8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 14:27:28 +0200 Subject: Add expandable method section for each class instance declaration. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 52 ++++++++++++++++-------- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 16 +++++++- 2 files changed, 50 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index afbbaad1..22b34228 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -269,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances links instances Nothing docname unicode qual + = ppInstances links instances Nothing docname splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -493,37 +493,54 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances links instances (Just sigs) nm unicode qual + instancesBit = ppInstances links instances (Just sigs) nm splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName - -> Unicode -> Qualification + -> Splice -> Unicode -> Qualification -> Html -ppInstances links instances _ baseName unicode qual - = subInstances qual instName links True (map instDecl instances) +ppInstances links instances msigs baseName splice unicode qual + = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> (SubDecl,Located DocName) - instDecl (inst, maybeDoc,l) = - ((ppInstHead links unicode qual inst, maybeDoc, []),l) + instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl iid (inst, maybeDoc,l) = + ((ppInstHead links splice unicode qual msigs iid inst, maybeDoc, []),l) -ppInstHead :: LinksInfo -> Unicode -> Qualification - -> InstHead DocName + +ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification + -> Maybe [Sig DocName] -> Int -> InstHead DocName -> Html -ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of - ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ - TypeInst rhs -> keyword "type" <+> typ - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - DataInst dd -> keyword "data" <+> typ - <+> ppShortDataDecl False True dd unicode qual +ppInstHead links splice unicode qual msigs iid (InstHead {..}) = + case ihdInstType of + ClassInst cs | Just sigs <- msigs -> + subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets sigs) + where + hdr = ppContextNoLocs cs unicode qual <+> typ + mets = ppInstanceSigs links splice unicode qual + nameStr = occNameString . nameOccName $ getName ihdClsName + ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ + TypeInst rhs -> keyword "type" <+> typ + <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + DataInst dd -> keyword "data" <+> typ + <+> ppShortDataDecl False True dd unicode qual where typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual +ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification + -> [Sig DocName] + -> [Html] +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames (L sspan typ) _ <- sigs + let names = map unLoc lnames + return $ ppFunSig False links sspan noDocForDecl names typ [] splice unicode qual + + lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n @@ -593,7 +610,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances links instances Nothing docname unicode qual + instancesBit = ppInstances links instances Nothing docname + splice unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 4714c1b6..188b4243 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, + subInstances, subClsInstance, subMethods, subMinimal, @@ -200,6 +200,20 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm + +-- | Generate class instance div with specialized methods. +subClsInstance :: String -- ^ Section unique id + -> Html -- ^ Header contents (instance name and type) + -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html +subClsInstance sid hdr mets = + hdrDiv <+> methodDiv + where + anchorId = makeAnchorId $ "i:" ++ sid + hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr + methodDiv = thediv ! collapseSection anchorId False [] << subMethods mets + + subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock -- cgit v1.2.3 From 0a02b70bea9781e4c1d03e88bcfe404934e4e2c6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 18:21:05 +0200 Subject: Move dummy post-family instances for `DocName` to `Types` module. --- haddock-api/src/Haddock/Interface/Rename.hs | 12 ------------ haddock-api/src/Haddock/Types.hs | 17 +++++++++++++++-- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index d222c6d2..44635318 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} ---------------------------------------------------------------------------- -- | @@ -22,8 +21,6 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import NameSet -import Coercion import Control.Applicative import Control.Monad hiding (mapM) @@ -526,12 +523,3 @@ renameSub (n,doc) = do n' <- rename n doc' <- renameDocForDecl doc return (n', doc') - -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder - -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index d9ae6cab..5a03af66 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -27,11 +27,15 @@ import Control.Arrow hiding ((<+>)) import Control.DeepSeq import Data.Typeable import Data.Map (Map) +import Data.Data (Data) import qualified Data.Map as Map import Documentation.Haddock.Types import BasicTypes (Fixity(..)) + import GHC hiding (NoLink) import DynFlags (ExtensionFlag, Language) +import Coercion +import NameSet import OccName import Outputable import Control.Monad (ap) @@ -280,7 +284,16 @@ data DocName | Undocumented Name -- ^ This thing is not part of the (existing or resulting) -- documentation, as far as Haddock knows. - deriving Eq + deriving (Eq, Data) + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder instance NamedThing DocName where -- cgit v1.2.3 From 6fc527b41b1ba80c706a375420f40e6eed8c81c8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 18:25:36 +0200 Subject: Create convenience functions for type specialization module. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 31 ++++++++++++++++++---- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index e8e80da1..fa5ba536 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} -module Haddock.Backends.Xhtml.Specialize (specialize) where +module Haddock.Backends.Xhtml.Specialize + ( specialize, specialize' + , specializeTyVarBndrs + ) where import Haddock.Syb @@ -14,8 +17,26 @@ import Data.Data specialize :: (Eq name, Typeable name) => Data a => name -> HsType name -> a -> a -specialize name details = everywhere (mkT $ specialize' name details) +specialize name details = everywhere (mkT $ specializeStep name details) -specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name -specialize' name details (HsTyVar name') | name == name' = details -specialize' _ _ typ = typ + +specialize' :: (Eq name, Typeable name) + => Data a + => [(name, HsType name)] -> a -> a +specialize' = flip $ foldr (uncurry specialize) + + +specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name +specializeStep name details (HsTyVar name') | name == name' = details +specializeStep _ _ typ = typ + + +specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) + => LHsTyVarBndrs name -> [HsType name] + -> HsType name -> HsType name +specializeTyVarBndrs bndrs typs = + specialize' $ zip bndrs' typs + where + bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs + bname (UserTyVar name) = name + bname (KindedTyVar (L _ name) _) = name -- cgit v1.2.3 From d6741ee8d407a8ac3c16e5bbddb657cab442a14c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 18:28:17 +0200 Subject: Hook type specialization logic with HTML pretty-printer. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 28 +++++++++++++++----------- haddock-api/src/Haddock/Types.hs | 6 ++++++ 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 22b34228..2a820531 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -22,6 +22,7 @@ module Haddock.Backends.Xhtml.Decl ( import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Specialize import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils @@ -493,32 +494,33 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances links instances (Just sigs) nm splice unicode qual + instSpec = Just $ InstSpec { ispecSigs = sigs, ispecTyVars = ltyvars } + instancesBit = ppInstances links instances instSpec nm splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo - -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName + -> [DocInstance DocName] -> Maybe (InstSpec DocName) -> DocName -> Splice -> Unicode -> Qualification -> Html -ppInstances links instances msigs baseName splice unicode qual +ppInstances links instances mspec baseName splice unicode qual = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl iid (inst, maybeDoc,l) = - ((ppInstHead links splice unicode qual msigs iid inst, maybeDoc, []),l) + ((ppInstHead links splice unicode qual iid mspec inst, maybeDoc, []),l) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> Maybe [Sig DocName] -> Int -> InstHead DocName + -> Int -> Maybe (InstSpec DocName) -> InstHead DocName -> Html -ppInstHead links splice unicode qual msigs iid (InstHead {..}) = +ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) = case ihdInstType of - ClassInst cs | Just sigs <- msigs -> - subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets sigs) + ClassInst cs | Just spec <- mspec -> + subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead) where hdr = ppContextNoLocs cs unicode qual <+> typ mets = ppInstanceSigs links splice unicode qual @@ -533,12 +535,14 @@ ppInstHead links splice unicode qual msigs iid (InstHead {..}) = ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> [Sig DocName] + -> InstSpec DocName -> InstHead DocName -> [Html] -ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames (L sspan typ) _ <- sigs +ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do + TypeSig lnames (L sspan typ) _ <- ispecSigs let names = map unLoc lnames - return $ ppFunSig False links sspan noDocForDecl names typ [] splice unicode qual + let typ' = specializeTyVarBndrs ispecTyVars ihdTypes typ + return $ ppFunSig False links sspan noDocForDecl names typ' [] + splice unicode qual lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5a03af66..76164b5e 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -328,6 +328,12 @@ data InstHead name = InstHead , ihdInstType :: InstType name } +-- | Instance details used for printing specialized method signatures. +data InstSpec name = InstSpec + { ispecTyVars :: LHsTyVarBndrs name + , ispecSigs :: [Sig name] + } + ----------------------------------------------------------------------------- -- * Documentation comments ----------------------------------------------------------------------------- -- cgit v1.2.3 From 1680145961545a3f2c2e184c2a5a661fb748d5a1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 18:42:17 +0200 Subject: Create stub functions for sugaring specialized types. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2a820531..f54b7c22 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -540,7 +540,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do TypeSig lnames (L sspan typ) _ <- ispecSigs let names = map unLoc lnames - let typ' = specializeTyVarBndrs ispecTyVars ihdTypes typ + let typ' = sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ return $ ppFunSig False links sspan noDocForDecl names typ' [] splice unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index fa5ba536..c10c7e6e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Xhtml.Specialize ( specialize, specialize' , specializeTyVarBndrs + , sugar ) where @@ -40,3 +41,15 @@ specializeTyVarBndrs bndrs typs = bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs bname (UserTyVar name) = name bname (KindedTyVar (L _ name) _) = name + + +sugar :: HsType name -> HsType name +sugar = sugarTuples . sugarLists + + +sugarLists :: HsType name -> HsType name +sugarLists = id + + +sugarTuples :: HsType name -> HsType name +sugarTuples = id -- cgit v1.2.3 From 3f31e24656d42bc6c50f441e055b7ecc4fdec8d0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 19:31:15 +0200 Subject: Implement list syntax sugaring logic for specialized types. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index c10c7e6e..30501a13 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Backends.Xhtml.Specialize @@ -11,6 +13,7 @@ module Haddock.Backends.Xhtml.Specialize import Haddock.Syb import GHC +import Name import Data.Data @@ -43,12 +46,22 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name -sugar :: HsType name -> HsType name +sugar :: (NamedThing name, DataId name) => HsType name -> HsType name sugar = sugarTuples . sugarLists -sugarLists :: HsType name -> HsType name -sugarLists = id +sugarLists :: forall name. (NamedThing name, DataId name) + => HsType name -> HsType name +sugarLists = everywhere $ mkT (sugarListsStep :: HsType name -> HsType name) + + +sugarListsStep :: NamedThing name => HsType name -> HsType name +sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp + where + name' = getName name + strName = occNameString . nameOccName $ name' +sugarListsStep typ = typ sugarTuples :: HsType name -> HsType name -- cgit v1.2.3 From 060b986c641cd496395b2d13dc316fc84462a7a4 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 20:25:41 +0200 Subject: Implement tuple syntax sugaring logic for specialized types. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 36 ++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 30501a13..a2cb8799 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -15,6 +15,7 @@ import Haddock.Syb import GHC import Name +import Control.Monad import Data.Data @@ -64,5 +65,36 @@ sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp) sugarListsStep typ = typ -sugarTuples :: HsType name -> HsType name -sugarTuples = id +sugarTuples :: forall name. (NamedThing name, DataId name) + => HsType name -> HsType name +sugarTuples = everywhere $ + mkT (sugarTuplesStep :: HsType name -> HsType name) + + +sugarTuplesStep :: NamedThing name => HsType name -> HsType name +sugarTuplesStep 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 name) + | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + where + name' = getName name + strName = occNameString . nameOccName $ name' + suitable = case parseTupleArity strName of + Just arity -> arity == length apps + Nothing -> False + aux _ _ = typ + + +parseTupleArity :: String -> Maybe Int +parseTupleArity ('(':commas) = do + n <- parseCommas commas + guard $ n /= 0 + return $ n + 1 + where + parseCommas (',':rest) = (+ 1) <$> parseCommas rest + parseCommas ")" = Just 0 + parseCommas _ = Nothing +parseTupleArity _ = Nothing -- cgit v1.2.3 From 6be6ca76e9163569ad3bed1441cb9fcfa7df0cec Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 15 Jul 2015 20:31:48 +0200 Subject: Get rid of code duplication in type specialization module. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 30 +++++++++------------- 1 file changed, 12 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a2cb8799..50cce3d5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -47,32 +47,26 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name -sugar :: (NamedThing name, DataId name) => HsType name -> HsType name -sugar = sugarTuples . sugarLists - - -sugarLists :: forall name. (NamedThing name, DataId name) - => HsType name -> HsType name -sugarLists = everywhere $ mkT (sugarListsStep :: HsType name -> HsType name) +sugar :: forall name. (NamedThing name, DataId name) + => HsType name -> HsType name +sugar = + everywhere $ mkT step + where + step :: HsType name -> HsType name + step = sugarTuples . sugarLists -sugarListsStep :: NamedThing name => HsType name -> HsType name -sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp) +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name strName = occNameString . nameOccName $ name' -sugarListsStep typ = typ - - -sugarTuples :: forall name. (NamedThing name, DataId name) - => HsType name -> HsType name -sugarTuples = everywhere $ - mkT (sugarTuplesStep :: HsType name -> HsType name) +sugarLists typ = typ -sugarTuplesStep :: NamedThing name => HsType name -> HsType name -sugarTuplesStep typ = +sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples typ = aux [] typ where aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp -- cgit v1.2.3 From 9edfaa67b6e4c80df43497f24133530d9a822dc6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 17 Jul 2015 13:57:28 +0200 Subject: Create scaffolding of a framework for renaming specialized types. --- haddock-api/haddock-api.cabal | 1 + .../src/Haddock/Backends/Xhtml/Specialize.hs | 97 +++++++++++++++++++++- 2 files changed, 97 insertions(+), 1 deletion(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index abe5adbe..2090c53e 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -43,6 +43,7 @@ library , filepath , directory , containers + , transformers , deepseq , array , xhtml >= 3000.2 && < 3000.3 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 50cce3d5..1a8446ee 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -6,7 +6,7 @@ module Haddock.Backends.Xhtml.Specialize ( specialize, specialize' , specializeTyVarBndrs - , sugar + , sugar, rename ) where @@ -16,7 +16,13 @@ import GHC import Name import Control.Monad +import Control.Monad.Trans.RWS + import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set specialize :: (Eq name, Typeable name) @@ -92,3 +98,92 @@ parseTupleArity ('(':commas) = do parseCommas ")" = Just 0 parseCommas _ = Nothing parseTupleArity _ = Nothing + + +rename :: Ord name => HsType name -> HsType name +rename = fst . evalRWS undefined Map.empty . renameType -- TODO. + + +type Rename name a = RWS (Set name) () (Map name name) a + + +renameType :: Ord name => HsType name -> Rename name (HsType name) +renameType (HsForAllTy ex mspan lbndrs lctx lt) = do + lbndrs' <- renameLTyVarBndrs lbndrs + HsForAllTy + <$> pure ex + <*> pure mspan + <*> pure lbndrs' + <*> located renameContext lctx + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> 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 (HsOpTy la lop lb) = HsOpTy + <$> renameLType la + <*> pure lop -- TODO. + <*> 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 t@(HsQuasiQuoteTy _) = pure t -- TODO. +renameType t@(HsSpliceTy _ _) = pure t -- TODO. +renameType t@(HsDocTy _ _) = pure t -- TODO. +renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt +renameType t@(HsRecTy _) = pure t -- TODO. +renameType t@(HsCoreTy _) = pure t +renameType t@(HsExplicitListTy _ _) = pure t -- TODO. +renameType t@(HsExplicitTupleTy _ _) = pure t -- TODO. +renameType t@(HsTyLit _) = pure t +renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t +renameType HsWildcardTy = pure HsWildcardTy +renameType t@(HsNamedWildcardTy _) = pure t -- TODO. + + +renameLType :: Ord name => LHsType name -> Rename name (LHsType name) +renameLType = located renameType + + +renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) +renameLTyVarBndrs lbndrs = do + tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs + pure $ lbndrs { hsq_tvs = tys' } + + +renameContext :: Ord name => HsContext name -> Rename name (HsContext name) +renameContext = mapM $ located renameType + + +renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name) +renameTyVarBndr (UserTyVar name) = + UserTyVar <$> renameNameBndr name +renameTyVarBndr (KindedTyVar name kinds) = + KindedTyVar <$> located renameNameBndr name <*> pure kinds + + +renameNameBndr :: Ord name => name -> Rename name name +renameNameBndr name = do + fv <- ask + when (name `Set.member` fv) $ + freshName name + renameName name + + +renameName :: Ord name => name -> Rename name name +renameName name = do + rnmap <- get + pure $ case Map.lookup name rnmap of + Just name' -> name' + Nothing -> name + + +freshName :: Ord name => name -> Rename name () +freshName _ = pure () -- TODO. + + +located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located f (L loc e) = L loc <$> f e -- cgit v1.2.3 From 51e145b013380965db7fe2a9983a3064cde57eb9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 17 Jul 2015 18:47:03 +0200 Subject: Fill in missing cases in specialized type renaming function. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 26 +++++++++++++--------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 1a8446ee..c59dd2c8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -122,26 +122,26 @@ 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 (HsOpTy la lop lb) = HsOpTy - <$> renameLType la - <*> pure lop -- TODO. - <*> renameLType lb +renameType (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> renameLTyOp 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 t@(HsQuasiQuoteTy _) = pure t -- TODO. -renameType t@(HsSpliceTy _ _) = pure t -- TODO. -renameType t@(HsDocTy _ _) = pure t -- TODO. +renameType t@(HsQuasiQuoteTy _) = pure t +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 -- TODO. +renameType t@(HsRecTy _) = pure t renameType t@(HsCoreTy _) = pure t -renameType t@(HsExplicitListTy _ _) = pure t -- TODO. -renameType t@(HsExplicitTupleTy _ _) = pure t -- TODO. +renameType (HsExplicitListTy ph ltys) = + HsExplicitListTy ph <$> mapM renameLType ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> mapM renameLType ltys renameType t@(HsTyLit _) = pure t renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t renameType HsWildcardTy = pure HsWildcardTy -renameType t@(HsNamedWildcardTy _) = pure t -- TODO. +renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name renameLType :: Ord name => LHsType name -> Rename name (LHsType name) @@ -165,6 +165,10 @@ renameTyVarBndr (KindedTyVar name kinds) = KindedTyVar <$> located renameNameBndr name <*> pure kinds +renameLTyOp :: Ord name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname + + renameNameBndr :: Ord name => name -> Rename name name renameNameBndr name = do fv <- ask -- cgit v1.2.3 From 1633853280a22aa1ddf682465eedaa1cf3b6905a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 17 Jul 2015 18:51:04 +0200 Subject: Remove code duplication in specialized type renamer. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index c59dd2c8..a7b7a561 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -135,9 +135,9 @@ renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt renameType t@(HsRecTy _) = pure t renameType t@(HsCoreTy _) = pure t renameType (HsExplicitListTy ph ltys) = - HsExplicitListTy ph <$> mapM renameLType ltys + HsExplicitListTy ph <$> renameLTypes ltys renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> mapM renameLType ltys + HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t renameType HsWildcardTy = pure HsWildcardTy @@ -148,16 +148,20 @@ renameLType :: Ord name => LHsType name -> Rename name (LHsType name) renameLType = located renameType +renameLTypes :: Ord name => [LHsType name] -> Rename name [LHsType name] +renameLTypes = mapM renameLType + + +renameContext :: Ord name => HsContext name -> Rename name (HsContext name) +renameContext = renameLTypes + + renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) renameLTyVarBndrs lbndrs = do tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs pure $ lbndrs { hsq_tvs = tys' } -renameContext :: Ord name => HsContext name -> Rename name (HsContext name) -renameContext = mapM $ located renameType - - renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name) renameTyVarBndr (UserTyVar name) = UserTyVar <$> renameNameBndr name -- cgit v1.2.3 From 4b352b94f07436d45dfcce8070c2f8301218b9ac Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 18 Jul 2015 19:05:46 +0200 Subject: Change state of the type renaming monad. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 30 ++++++++++++---------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a7b7a561..d2a51fac 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -100,14 +100,14 @@ parseTupleArity ('(':commas) = do parseTupleArity _ = Nothing -rename :: Ord name => HsType name -> HsType name +rename :: NamedThing name => HsType name -> HsType name rename = fst . evalRWS undefined Map.empty . renameType -- TODO. -type Rename name a = RWS (Set name) () (Map name name) a +type Rename name a = RWS (Set OccName) () (Map Name name) a -renameType :: Ord name => HsType name -> Rename name (HsType name) +renameType :: NamedThing name => HsType name -> Rename name (HsType name) renameType (HsForAllTy ex mspan lbndrs lctx lt) = do lbndrs' <- renameLTyVarBndrs lbndrs HsForAllTy @@ -144,52 +144,54 @@ renameType HsWildcardTy = pure HsWildcardTy renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name -renameLType :: Ord name => LHsType name -> Rename name (LHsType name) +renameLType :: NamedThing name => LHsType name -> Rename name (LHsType name) renameLType = located renameType -renameLTypes :: Ord name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: NamedThing name => [LHsType name] -> Rename name [LHsType name] renameLTypes = mapM renameLType -renameContext :: Ord name => HsContext name -> Rename name (HsContext name) +renameContext :: NamedThing name => HsContext name + -> Rename name (HsContext name) renameContext = renameLTypes -renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) +renameLTyVarBndrs :: NamedThing name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) renameLTyVarBndrs lbndrs = do tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs pure $ lbndrs { hsq_tvs = tys' } -renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name) +renameTyVarBndr :: NamedThing name => HsTyVarBndr name + -> Rename name (HsTyVarBndr name) renameTyVarBndr (UserTyVar name) = UserTyVar <$> renameNameBndr name renameTyVarBndr (KindedTyVar name kinds) = KindedTyVar <$> located renameNameBndr name <*> pure kinds -renameLTyOp :: Ord name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp :: NamedThing name => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname -renameNameBndr :: Ord name => name -> Rename name name +renameNameBndr :: NamedThing name => name -> Rename name name renameNameBndr name = do fv <- ask - when (name `Set.member` fv) $ + when (getOccName name `Set.member` fv) $ freshName name renameName name -renameName :: Ord name => name -> Rename name name +renameName :: NamedThing name => name -> Rename name name renameName name = do rnmap <- get - pure $ case Map.lookup name rnmap of + pure $ case Map.lookup (getName name) rnmap of Just name' -> name' Nothing -> name -freshName :: Ord name => name -> Rename name () +freshName :: NamedThing name => name -> Rename name () freshName _ = pure () -- TODO. -- cgit v1.2.3 From d508387d8bca5cdc7e29127ac859f170b66f81df Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 18 Jul 2015 20:48:48 +0200 Subject: Implement simple mechanism for generating new type names. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 29 +++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index d2a51fac..2c4c8498 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -19,6 +19,8 @@ import Control.Monad import Control.Monad.Trans.RWS import Data.Data +import qualified Data.List as List +import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -185,14 +187,35 @@ renameNameBndr name = do renameName :: NamedThing name => name -> Rename name name renameName name = do - rnmap <- get - pure $ case Map.lookup (getName name) rnmap of + env <- get + pure $ case Map.lookup (getName name) env of Just name' -> name' Nothing -> name freshName :: NamedThing name => name -> Rename name () -freshName _ = pure () -- TODO. +freshName name = do + fv <- ask + env <- get + let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env) + let name' = undefined $ findFreshName taken occ + put $ Map.insert (getName name) name' env + where + occ = getOccName name + + +findFreshName :: Set OccName -> OccName -> OccName +findFreshName taken = + fromJust . List.find isFresh . alternativeNames + where + isFresh = not . flip Set.member taken + + +alternativeNames :: OccName -> [OccName] +alternativeNames name = + [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ] + where + str = occNameString name located :: Functor f => (a -> f b) -> Located a -> f (Located b) -- cgit v1.2.3 From 0495d71981573cf95f28468c7167b96ffd48ac11 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 18 Jul 2015 21:02:07 +0200 Subject: Fill in stub behaviour with actual environment renaming. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 42 ++++++++++++++-------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 2c4c8498..a9c46463 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -102,14 +102,27 @@ parseTupleArity ('(':commas) = do parseTupleArity _ = Nothing -rename :: NamedThing name => HsType name -> HsType name +class NamedThing name => SetName name where + + setName :: Name -> name -> name + + +setInternalOccName :: SetName name => OccName -> name -> name +setInternalOccName occ name = + setName nname' name + where + nname = getName name + nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) + + +rename :: SetName name => HsType name -> HsType name rename = fst . evalRWS undefined Map.empty . renameType -- TODO. type Rename name a = RWS (Set OccName) () (Map Name name) a -renameType :: NamedThing name => HsType name -> Rename name (HsType name) +renameType :: SetName name => HsType name -> Rename name (HsType name) renameType (HsForAllTy ex mspan lbndrs lctx lt) = do lbndrs' <- renameLTyVarBndrs lbndrs HsForAllTy @@ -146,26 +159,26 @@ renameType HsWildcardTy = pure HsWildcardTy renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name -renameLType :: NamedThing name => LHsType name -> Rename name (LHsType name) +renameLType :: SetName name => LHsType name -> Rename name (LHsType name) renameLType = located renameType -renameLTypes :: NamedThing name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] renameLTypes = mapM renameLType -renameContext :: NamedThing name => HsContext name +renameContext :: SetName name => HsContext name -> Rename name (HsContext name) renameContext = renameLTypes -renameLTyVarBndrs :: NamedThing name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) +renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) renameLTyVarBndrs lbndrs = do tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs pure $ lbndrs { hsq_tvs = tys' } -renameTyVarBndr :: NamedThing name => HsTyVarBndr name +renameTyVarBndr :: SetName name => HsTyVarBndr name -> Rename name (HsTyVarBndr name) renameTyVarBndr (UserTyVar name) = UserTyVar <$> renameNameBndr name @@ -173,11 +186,11 @@ renameTyVarBndr (KindedTyVar name kinds) = KindedTyVar <$> located renameNameBndr name <*> pure kinds -renameLTyOp :: NamedThing name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname -renameNameBndr :: NamedThing name => name -> Rename name name +renameNameBndr :: SetName name => name -> Rename name name renameNameBndr name = do fv <- ask when (getOccName name `Set.member` fv) $ @@ -185,7 +198,7 @@ renameNameBndr name = do renameName name -renameName :: NamedThing name => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do env <- get pure $ case Map.lookup (getName name) env of @@ -193,15 +206,16 @@ renameName name = do Nothing -> name -freshName :: NamedThing name => name -> Rename name () +freshName :: SetName name => name -> Rename name () freshName name = do fv <- ask env <- get let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env) - let name' = undefined $ findFreshName taken occ - put $ Map.insert (getName name) name' env + let name' = setInternalOccName (findFreshName taken occ) name + put $ Map.insert nname name' env where - occ = getOccName name + nname = getName name + occ = nameOccName nname findFreshName :: Set OccName -> OccName -> OccName -- cgit v1.2.3 From 2c94f5a7804ecf84f818a64ba41ca5829621323c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 19 Jul 2015 15:57:10 +0200 Subject: Fix logic behind binder type renaming. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a9c46463..6a149719 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -193,9 +193,11 @@ renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname renameNameBndr :: SetName name => name -> Rename name name renameNameBndr name = do fv <- ask - when (getOccName name `Set.member` fv) $ - freshName name - renameName name + env <- get + case Map.lookup (getName name) env of + Just name' -> pure name' + Nothing | getOccName name `Set.member` fv -> freshName name + Nothing -> pure name renameName :: SetName name => name -> Rename name name @@ -206,13 +208,14 @@ renameName name = do Nothing -> name -freshName :: SetName name => name -> Rename name () +freshName :: SetName name => name -> Rename name name freshName name = do fv <- ask env <- get let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env) let name' = setInternalOccName (findFreshName taken occ) name put $ Map.insert nname name' env + return name' where nname = getName name occ = nameOccName nname -- cgit v1.2.3 From d5700e1427f7171db0e0e9393aedb734b554459f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 19 Jul 2015 18:16:11 +0200 Subject: Add SYB-like utility function for performing stateful queries. --- haddock-api/src/Haddock/Syb.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 2016b74c..4847e486 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -2,7 +2,7 @@ module Haddock.Syb - ( everything, everywhere + ( everything, everythingWithState, everywhere , mkT , combine ) where @@ -20,6 +20,20 @@ everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +-- | Perform a query with state on each level of a tree. +-- +-- This is the same as 'everything' but allows for stateful computations. In +-- SYB it is called @everythingWithContext@ but I find this name somewhat +-- nicer. +everythingWithState :: s -> (r -> r -> r) + -> (forall a. Data a => a -> s -> (r, s)) + -> (forall a. Data a => a -> r) +everythingWithState s k f x = + let (r, s') = f x s + in foldl k r (gmapQ (everythingWithState s' k f) x) + + -- | Apply transformation on each level of a tree. -- -- Just like 'everything', this is stolen from SYB package. -- cgit v1.2.3 From 77b628b79bd179e7dde83d44bbea5acb4c0cb043 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 19 Jul 2015 20:30:06 +0200 Subject: Create function for retrieving free variables from given type. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 6a149719..7e568933 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -159,6 +159,21 @@ renameType HsWildcardTy = pure HsWildcardTy renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name +freeVariables :: forall name. (NamedThing name, Data (HsType name)) + => HsType name -> Set OccName +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy _ _ bndrs _ _) -> + (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsTyVar name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getOccName name, ctx) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + + renameLType :: SetName name => LHsType name -> Rename name (LHsType name) renameLType = located renameType @@ -237,3 +252,8 @@ alternativeNames name = located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr name -> name +tyVarName (UserTyVar name) = name +tyVarName (KindedTyVar (L _ name) _) = name -- cgit v1.2.3 From 532478bcee19cf465a6a0ad24e05c6a571213c05 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 20 Jul 2015 12:50:31 +0200 Subject: Fix compilation error caused by incorrect type signature. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 7e568933..37632ee7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -159,7 +159,7 @@ renameType HsWildcardTy = pure HsWildcardTy renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name -freeVariables :: forall name. (NamedThing name, Data (HsType name)) +freeVariables :: forall name. (NamedThing name, DataId name) => HsType name -> Set OccName freeVariables = everythingWithState Set.empty Set.union query -- cgit v1.2.3 From 8135ce02b26385a610587abb26775055c5323b31 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 20 Jul 2015 13:52:21 +0200 Subject: Move `SetName` class definition to types module. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 6 +----- haddock-api/src/Haddock/Types.hs | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 37632ee7..4e68cb7b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -11,6 +11,7 @@ module Haddock.Backends.Xhtml.Specialize import Haddock.Syb +import Haddock.Types import GHC import Name @@ -102,11 +103,6 @@ parseTupleArity ('(':commas) = do parseTupleArity _ = Nothing -class NamedThing name => SetName name where - - setName :: Name -> name -> name - - setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name = setName nname' name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 76164b5e..c5ca31c0 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -301,6 +301,23 @@ instance NamedThing DocName where getName (Undocumented name) = name +class NamedThing name => SetName name where + + setName :: Name -> name -> name + + +instance SetName Name where + + setName name' _ = name' + + +instance SetName DocName where + + setName name' (Documented _ mdl) = Documented name' mdl + setName name' (Undocumented _) = Undocumented name' + + + ----------------------------------------------------------------------------- -- * Instances ----------------------------------------------------------------------------- -- cgit v1.2.3 From 70ed9912b5400b1b2afd60cd8bd3585e3d355a5a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 20 Jul 2015 13:59:13 +0200 Subject: Hook type renamer with instance method HTML pretty-printer. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++++- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 5 +++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f54b7c22..176180ad 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -31,6 +31,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) @@ -540,9 +541,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do TypeSig lnames (L sspan typ) _ <- ispecSigs let names = map unLoc lnames - let typ' = sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ + let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ return $ ppFunSig False links sspan noDocForDecl names typ' [] splice unicode qual + where + fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes + rename' = rename fv lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 4e68cb7b..3b3d95b9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -7,6 +7,7 @@ module Haddock.Backends.Xhtml.Specialize ( specialize, specialize' , specializeTyVarBndrs , sugar, rename + , freeVariables ) where @@ -111,8 +112,8 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) -rename :: SetName name => HsType name -> HsType name -rename = fst . evalRWS undefined Map.empty . renameType -- TODO. +rename :: SetName name => Set OccName -> HsType name -> HsType name +rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty type Rename name a = RWS (Set OccName) () (Map Name name) a -- cgit v1.2.3 From a314ebd0af69cc1f6c76bfd8242d88d47277fcda Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 20 Jul 2015 18:16:26 +0200 Subject: Add some test cases for type renamer. --- html-test/src/Instances.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index d0d68dc3..8e237fe7 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImpredicativeTypes #-} module Instances where @@ -34,3 +35,20 @@ instance Bar Maybe [a] instance Bar [] (a, a) instance Foo f => Bar (Either a) (f a) instance Foo ((,,) a b) => Bar ((,,) a b) (a, b, a) + + +class Baz a where + + baz :: a -> (forall a. a -> a) -> (b, forall c. c -> a) -> (b, c) + baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)] + baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> (forall c. c -> b) + + baz = undefined + baz' = undefined + baz'' = undefined + + +instance Baz (a -> b) +instance Baz [c] +instance Baz (a, b, c) +instance Baz (a, [b], b, a) -- cgit v1.2.3 From b4a82b390e3b6d7d5f1c10c42c4e36d5d7cf667b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 13:43:48 +0200 Subject: Make specialized signatures refer to original signature declaration. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++++++-- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 176180ad..b3e1db81 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -223,6 +223,14 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix +ppSimpleSig :: Unicode -> Qualification -> [DocName] -> HsType DocName -> Html +ppSimpleSig unicode qual names typ = + ppTypeSig True occNames ppTyp unicode + where + ppTyp = ppType unicode qual typ + occNames = map getOccName names + + -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- @@ -542,8 +550,7 @@ ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do TypeSig lnames (L sspan typ) _ <- ispecSigs let names = map unLoc lnames let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ - return $ ppFunSig False links sspan noDocForDecl names typ' [] - splice unicode qual + return $ ppSimpleSig unicode qual names typ' where fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes rename' = rename fv diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 188b4243..d971b0e5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -211,7 +211,7 @@ subClsInstance sid hdr mets = where anchorId = makeAnchorId $ "i:" ++ sid hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr - methodDiv = thediv ! collapseSection anchorId False [] << subMethods mets + methodDiv = thediv ! collapseSection anchorId False [] << subBlock mets subMethods :: [Html] -> Html -- cgit v1.2.3 From 59d809746c08e3e3e506da5eeaaaed9d04407743 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 14:36:37 +0200 Subject: Make specialized methods be nicely formatted again. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b3e1db81..4862945a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -223,10 +223,14 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix -ppSimpleSig :: Unicode -> Qualification -> [DocName] -> HsType DocName -> Html -ppSimpleSig unicode qual names typ = - ppTypeSig True occNames ppTyp unicode +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification + -> [DocName] -> HsType DocName + -> Html +ppSimpleSig links splice unicode qual names typ = + topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where + -- TODO: Use *helpful* source span. + topDeclElem' = topDeclElem links (UnhelpfulSpan undefined) splice ppTyp = ppType unicode qual typ occNames = map getOccName names @@ -550,7 +554,7 @@ ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do TypeSig lnames (L sspan typ) _ <- ispecSigs let names = map unLoc lnames let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ - return $ ppSimpleSig unicode qual names typ' + return $ ppSimpleSig links splice unicode qual names typ' where fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes rename' = rename fv -- cgit v1.2.3 From 42d49d550642aa58696af91bb250487ac42e9095 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 14:44:22 +0200 Subject: Attach source locations to the specialized class methods. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4862945a..67405915 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -223,14 +223,13 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan -> [DocName] -> HsType DocName -> Html -ppSimpleSig links splice unicode qual names typ = +ppSimpleSig links splice unicode qual loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where - -- TODO: Use *helpful* source span. - topDeclElem' = topDeclElem links (UnhelpfulSpan undefined) splice + topDeclElem' = topDeclElem links loc splice ppTyp = ppType unicode qual typ occNames = map getOccName names @@ -551,10 +550,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> InstSpec DocName -> InstHead DocName -> [Html] ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do - TypeSig lnames (L sspan typ) _ <- ispecSigs + TypeSig lnames (L loc typ) _ <- ispecSigs let names = map unLoc lnames let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ - return $ ppSimpleSig links splice unicode qual names typ' + return $ ppSimpleSig links splice unicode qual loc names typ' where fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes rename' = rename fv -- cgit v1.2.3 From dbe6f2ce44d28cbd0cad7e5ed3b9e1766fdae8ee Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 14:47:35 +0200 Subject: Extend instances test case to also test multi-name type signatures. --- html-test/src/Instances.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index 8e237fe7..85c21754 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -26,9 +26,13 @@ class Foo f => Bar f a where bar :: f a -> f Bool -> a bar' :: f (f a) -> f (f (f b)) + bar0, bar1 :: (f a, f a) -> (f b, f c) bar = undefined bar' = undefined + bar0 = undefined + bar1 = undefined + instance Bar Maybe Bool instance Bar Maybe [a] -- cgit v1.2.3 From 2d9b75f5f656aecbc30410350a6e9059a78b1516 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 14:49:58 +0200 Subject: Fix tab-based indentation in instances test case. --- html-test/src/Instances.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index 85c21754..9886fb69 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -43,13 +43,13 @@ instance Foo ((,,) a b) => Bar ((,,) a b) (a, b, a) class Baz a where - baz :: a -> (forall a. a -> a) -> (b, forall c. c -> a) -> (b, c) - baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)] - baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> (forall c. c -> b) + baz :: a -> (forall a. a -> a) -> (b, forall c. c -> a) -> (b, c) + baz' :: b -> (forall b. b -> a) -> (forall b. b -> a) -> [(b, a)] + baz'' :: b -> (forall b. (forall b. b -> a) -> c) -> (forall c. c -> b) - baz = undefined - baz' = undefined - baz'' = undefined + baz = undefined + baz' = undefined + baz'' = undefined instance Baz (a -> b) -- cgit v1.2.3 From f0edea1969cdc06d0299c606debf533d7ece77f0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 19:22:30 +0200 Subject: Improve placement of instance methods expander button. --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 14 ++++++++++---- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 6 +++--- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 9ad9f9d2..428040bc 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -146,15 +146,21 @@ ul.links li a { background-image: url(plus.gif); background-repeat: no-repeat; } -p.caption.collapser, -p.caption.expander { - background-position: 0 0.4em; -} .collapser, .expander { padding-left: 14px; margin-left: -14px; cursor: pointer; } +p.caption.collapser, +p.caption.expander { + background-position: 0 0.4em; +} + +.instance.collapser, .instance.expander { + margin-left: 0px; + background-position: left center; +} + pre { padding: 0.25em; diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d971b0e5..460cc6d7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -207,11 +207,11 @@ subClsInstance :: String -- ^ Section unique id -> [Html] -- ^ Method contents (pretty-printed signatures) -> Html subClsInstance sid hdr mets = - hdrDiv <+> methodDiv + (hdrDiv << hdr) <+> (methodDiv << subBlock mets) where anchorId = makeAnchorId $ "i:" ++ sid - hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr - methodDiv = thediv ! collapseSection anchorId False [] << subBlock mets + hdrDiv = thediv ! collapseControl anchorId False "instance" + methodDiv = thediv ! collapseSection anchorId False "methods" subMethods :: [Html] -> Html -- cgit v1.2.3 From 1700278e2d5978d098f2acb610442df2bc0ae02a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 19:29:58 +0200 Subject: Add new data type declaration to instance specialization test case. --- html-test/src/Instances.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index 9886fb69..58bdc873 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -56,3 +56,10 @@ instance Baz (a -> b) instance Baz [c] instance Baz (a, b, c) instance Baz (a, [b], b, a) + + +data Quux a b c = Qx a | Qux a b | Quux a b c + +instance Foo (Quux a b) +instance Bar (Quux a c) (Quux a b c) +instance Baz (Quux a b c) -- cgit v1.2.3 From aec90be7b95b2116e3c436b91b7c35aec026f6cc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 21 Jul 2015 19:44:33 +0200 Subject: Make type renamer first try single-letter names as alternatives. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 3b3d95b9..c127ebbd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -241,7 +241,15 @@ findFreshName taken = alternativeNames :: OccName -> [OccName] -alternativeNames name = +alternativeNames name + | [_] <- occNameString name = letterNames ++ alternativeNames' name + where + letterNames = map (mkVarOcc . pure) ['a'..'z'] +alternativeNames name = alternativeNames' name + + +alternativeNames' :: OccName -> [OccName] +alternativeNames' name = [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ] where str = occNameString name -- cgit v1.2.3 From 08e592eb55c4f4f86fe824e572517be7e44b2cb8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 22 Jul 2015 00:09:10 +0200 Subject: Fix type renamer bug with incorrect names being generated. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 45 ++++++++++++++-------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index c127ebbd..fccdaa95 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -16,6 +16,7 @@ import Haddock.Types import GHC import Name +import FastString import Control.Monad import Control.Monad.Trans.RWS @@ -104,6 +105,20 @@ parseTupleArity ('(':commas) = do parseTupleArity _ = Nothing +type NameRep = FastString + +getNameRep :: NamedThing name => name -> NameRep +getNameRep = occNameFS . getOccName + +nameRepString :: NameRep -> String +nameRepString = unpackFS + +stringNameRep :: String -> NameRep +stringNameRep = mkFastString + +setInternalNameRep :: SetName name => NameRep -> name -> name +setInternalNameRep = setInternalOccName . mkVarOccFS + setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name = setName nname' name @@ -112,11 +127,11 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) -rename :: SetName name => Set OccName -> HsType name -> HsType name +rename :: SetName name => Set NameRep -> HsType name -> HsType name rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty -type Rename name a = RWS (Set OccName) () (Map Name name) a +type Rename name a = RWS (Set NameRep) () (Map Name name) a renameType :: SetName name => HsType name -> Rename name (HsType name) @@ -157,7 +172,7 @@ renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set OccName + => HsType name -> Set NameRep freeVariables = everythingWithState Set.empty Set.union query where @@ -166,7 +181,7 @@ freeVariables = (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar name) | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getOccName name, ctx) + | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx) bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs @@ -208,7 +223,7 @@ renameNameBndr name = do env <- get case Map.lookup (getName name) env of Just name' -> pure name' - Nothing | getOccName name `Set.member` fv -> freshName name + Nothing | getNameRep name `Set.member` fv -> freshName name Nothing -> pure name @@ -224,35 +239,35 @@ freshName :: SetName name => name -> Rename name name freshName name = do fv <- ask env <- get - let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env) - let name' = setInternalOccName (findFreshName taken occ) name + let taken = Set.union fv (Set.fromList . map getNameRep . Map.keys $ env) + let name' = setInternalNameRep (findFreshName taken occ) name put $ Map.insert nname name' env return name' where nname = getName name - occ = nameOccName nname + occ = getNameRep nname -findFreshName :: Set OccName -> OccName -> OccName +findFreshName :: Set NameRep -> NameRep -> NameRep findFreshName taken = fromJust . List.find isFresh . alternativeNames where isFresh = not . flip Set.member taken -alternativeNames :: OccName -> [OccName] +alternativeNames :: NameRep -> [NameRep] alternativeNames name - | [_] <- occNameString name = letterNames ++ alternativeNames' name + | [_] <- nameRepString name = letterNames ++ alternativeNames' name where - letterNames = map (mkVarOcc . pure) ['a'..'z'] + letterNames = map (stringNameRep . pure) ['a'..'z'] alternativeNames name = alternativeNames' name -alternativeNames' :: OccName -> [OccName] +alternativeNames' :: NameRep -> [NameRep] alternativeNames' name = - [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ] + [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] where - str = occNameString name + str = nameRepString name located :: Functor f => (a -> f b) -> Located a -> f (Located b) -- cgit v1.2.3 From 0e3a90b9a1935a69b48dfb5906c346dd12c43ec1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 22 Jul 2015 15:55:59 +0200 Subject: Add some documentation and refactor type specialization module. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 95 +++++++++++++++++----- 1 file changed, 74 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index fccdaa95..1da089d9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -30,23 +30,31 @@ import Data.Set (Set) import qualified Data.Set as Set +-- | Instantiate all occurrences of given name with particular type. specialize :: (Eq name, Typeable name) => Data a => name -> HsType name -> a -> a -specialize name details = everywhere (mkT $ specializeStep name details) +specialize name details = + everywhere $ mkT step + where + step (HsTyVar name') | name == name' = details + step typ = typ +-- | Instantiate all occurrences of given names with corresponding types. +-- +-- It is just a convenience function wrapping 'specialize' that supports more +-- that one specialization. specialize' :: (Eq name, Typeable name) => Data a => [(name, HsType name)] -> a -> a specialize' = flip $ foldr (uncurry specialize) -specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name -specializeStep name details (HsTyVar name') | name == name' = details -specializeStep _ _ typ = typ - - +-- | Instantiate given binders with corresponding types. +-- +-- Again, it is just a convenience function around 'specialize'. Note that +-- length of type list should be the same as the number of binders. specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) => LHsTyVarBndrs name -> [HsType name] -> HsType name -> HsType name @@ -58,6 +66,12 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name +-- | Make given type use tuple and list literals where appropriate. +-- +-- After applying 'specialize' function some terms may not use idiomatic list +-- 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 name, DataId name) => HsType name -> HsType name sugar = @@ -93,6 +107,19 @@ sugarTuples typ = aux _ _ = typ +-- | Compute arity of given tuple operator. +-- +-- >>> parseTupleArity "(,,)" +-- Just 3 +-- +-- >>> parseTupleArity "(,,,,)" +-- Just 5 +-- +-- >>> parseTupleArity "abc" +-- Nothing +-- +-- >>> parseTupleArity "()" +-- Nothing parseTupleArity :: String -> Maybe Int parseTupleArity ('(':commas) = do n <- parseCommas commas @@ -105,6 +132,17 @@ parseTupleArity ('(':commas) = do parseTupleArity _ = Nothing +-- | Haskell AST type representation. +-- +-- This type is used for renaming (more below), essentially the ambiguous (!) +-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, +-- it was 'OccName' before, but turned out that 'OccName' sometimes also +-- contains namespace information, differentiating visually same types. +-- +-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is +-- not converted to 'String' or alike to avoid new allocations. Additionally, +-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also +-- quite nice. type NameRep = FastString getNameRep :: NamedThing name => name -> NameRep @@ -127,10 +165,39 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) +-- | Compute set of free variables of given type. +freeVariables :: forall name. (NamedThing name, DataId name) + => HsType name -> Set NameRep +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy _ _ bndrs _ _) -> + (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsTyVar name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getNameRep name, ctx) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + + +-- | Make given type visually unambiguous. +-- +-- After applying 'specialize' method, some free type variables may become +-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to +-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to +-- different type variable than latter one. Applying 'rename' function +-- will fix that type to be visually unambiguous again (making it something +-- like @(a -> c) -> b@). rename :: SetName name => Set NameRep -> HsType name -> HsType name rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty +-- | Renaming monad. +-- +-- This is just a simple RWS instance, where /reader/ part consists of names +-- that are initially taken and cannot change, /state/ part is just context +-- with name bindings and /writer/ part is not used. type Rename name a = RWS (Set NameRep) () (Map Name name) a @@ -171,21 +238,6 @@ renameType HsWildcardTy = pure HsWildcardTy renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep -freeVariables = - everythingWithState Set.empty Set.union query - where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy _ _ bndrs _ _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar name) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) - _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs - - renameLType :: SetName name => LHsType name -> Rename name (LHsType name) renameLType = located renameType @@ -235,6 +287,7 @@ renameName name = do Nothing -> name +-- | Generate fresh occurrence name, put it into context and return. freshName :: SetName name => name -> Rename name name freshName name = do fv <- ask -- cgit v1.2.3 From dfb697b2d41319a6c14134edcd89da2fa49ecd99 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 22 Jul 2015 17:20:28 +0200 Subject: Fix another bug where type renamer was generating incorrect names. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 1da089d9..47a96b34 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -292,7 +292,7 @@ freshName :: SetName name => name -> Rename name name freshName name = do fv <- ask env <- get - let taken = Set.union fv (Set.fromList . map getNameRep . Map.keys $ env) + let taken = Set.union fv (Set.fromList . map getNameRep . Map.elems $ env) let name' = setInternalNameRep (findFreshName taken occ) name put $ Map.insert nname name' env return name' -- cgit v1.2.3 From 3f404ba3c1b36212ae7507874aefb1e8cc107dd8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 22 Jul 2015 18:46:10 +0200 Subject: Refactor type renamer to rebinding and pure renaming phases. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 105 ++++++++++++--------- 1 file changed, 60 insertions(+), 45 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 47a96b34..69cd939b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} module Haddock.Backends.Xhtml.Specialize @@ -19,7 +20,8 @@ import Name import FastString import Control.Monad -import Control.Monad.Trans.RWS +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State import Data.Data import qualified Data.List as List @@ -190,20 +192,26 @@ freeVariables = -- will fix that type to be visually unambiguous again (making it something -- like @(a -> c) -> b@). rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty +rename fv typ = runReader (renameType typ) $ RenameEnv + { rneFV = fv + , rneCtx = Map.empty + } -- | Renaming monad. --- --- This is just a simple RWS instance, where /reader/ part consists of names --- that are initially taken and cannot change, /state/ part is just context --- with name bindings and /writer/ part is not used. -type Rename name a = RWS (Set NameRep) () (Map Name name) a +type Rename name = Reader (RenameEnv name) + +-- | Binding generation monad. +type Rebind name = State (RenameEnv name) + +data RenameEnv name = RenameEnv + { rneFV :: Set NameRep + , rneCtx :: Map Name name + } renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy ex mspan lbndrs lctx lt) = do - lbndrs' <- renameLTyVarBndrs lbndrs +renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> HsForAllTy <$> pure ex <*> pure mspan @@ -246,66 +254,73 @@ renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] renameLTypes = mapM renameLType -renameContext :: SetName name => HsContext name - -> Rename name (HsContext name) +renameContext :: SetName name => HsContext name -> Rename name (HsContext name) renameContext = renameLTypes -renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name) -renameLTyVarBndrs lbndrs = do - tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs - pure $ lbndrs { hsq_tvs = tys' } - - -renameTyVarBndr :: SetName name => HsTyVarBndr name - -> Rename name (HsTyVarBndr name) -renameTyVarBndr (UserTyVar name) = - UserTyVar <$> renameNameBndr name -renameTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located renameNameBndr name <*> pure kinds - - renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname -renameNameBndr :: SetName name => name -> Rename name name -renameNameBndr name = do - fv <- ask - env <- get - case Map.lookup (getName name) env of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` fv -> freshName name - Nothing -> pure name - - renameName :: SetName name => name -> Rename name name renameName name = do - env <- get - pure $ case Map.lookup (getName name) env of + RenameEnv { rneCtx = ctx } <- ask + pure $ case Map.lookup (getName name) ctx of Just name' -> name' Nothing -> name +rebind :: SetName name + => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a) + -> Rename name a +rebind lbndrs action = do + (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask + local (const env') (action lbndrs') + + +rebindLTyVarBndrs :: SetName name + => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) +rebindLTyVarBndrs lbndrs = do + tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs + pure $ lbndrs { hsq_tvs = tys' } + + +rebindTyVarBndr :: SetName name + => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) +rebindTyVarBndr (UserTyVar name) = + UserTyVar <$> rebindName name +rebindTyVarBndr (KindedTyVar name kinds) = + KindedTyVar <$> located rebindName name <*> pure kinds + + +rebindName :: SetName name => name -> Rebind name name +rebindName name = do + RenameEnv { .. } <- get + case Map.lookup (getName name) rneCtx of + Just name' -> pure name' + Nothing | getNameRep name `Set.member` rneFV -> freshName name + Nothing -> pure name + + -- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rename name name +freshName :: SetName name => name -> Rebind name name freshName name = do - fv <- ask - env <- get - let taken = Set.union fv (Set.fromList . map getNameRep . Map.elems $ env) - let name' = setInternalNameRep (findFreshName taken occ) name - put $ Map.insert nname name' env + env@RenameEnv { .. } <- get + let taken = Set.union rneFV (elems' rneCtx) + let name' = setInternalNameRep (findFreshName taken rep) name + put $ env { rneCtx = Map.insert nname name' rneCtx } return name' where + elems' = Set.fromList . map getNameRep . Map.elems nname = getName name - occ = getNameRep nname + rep = getNameRep nname findFreshName :: Set NameRep -> NameRep -> NameRep findFreshName taken = fromJust . List.find isFresh . alternativeNames where - isFresh = not . flip Set.member taken + isFresh = not . Set.member taken alternativeNames :: NameRep -> [NameRep] -- cgit v1.2.3 From bea9253315b8b5beb6f66896eaceda92800ab32f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 22 Jul 2015 19:21:27 +0200 Subject: Fix unwitting compilation bug. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 69cd939b..78af98b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -320,7 +320,7 @@ findFreshName :: Set NameRep -> NameRep -> NameRep findFreshName taken = fromJust . List.find isFresh . alternativeNames where - isFresh = not . Set.member taken + isFresh = not . flip Set.member taken alternativeNames :: NameRep -> [NameRep] -- cgit v1.2.3 From 85dab3d6aacf867a381c8810deaf585a43d42d43 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 23 Jul 2015 19:15:13 +0200 Subject: Integrate instance specification type into class instance definition. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Convert.hs | 8 ++++++-- haddock-api/src/Haddock/Interface/Rename.hs | 5 ++++- haddock-api/src/Haddock/Types.hs | 13 ++++++++++--- 5 files changed, 23 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 59e5af3e..47087911 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -562,7 +562,7 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX ppInstHead unicode (InstHead {..}) = case ihdInstType of - ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ + ClassInst ctx _ _ -> ppContextNoLocs ctx unicode <+> typ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs DataInst _ -> error "data instances not supported by --latex yet" where diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 67405915..a894972e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -531,13 +531,13 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Html ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) = case ihdInstType of - ClassInst cs | Just spec <- mspec -> + ClassInst cs _ _ | Just spec <- mspec -> subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead) where hdr = ppContextNoLocs cs unicode qual <+> typ mets = ppInstanceSigs links splice unicode qual nameStr = occNameString . nameOccName $ getName ihdClsName - ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ + ClassInst cs _ _ -> ppContextNoLocs cs unicode qual <+> typ TypeInst rhs -> keyword "type" <+> typ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs DataInst dd -> keyword "data" <+> typ diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index e51d9df7..3479780a 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -390,11 +390,15 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = InstHead +synifyInstHead (tyvars, preds, cls, types) = InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks , ihdTypes = map (unLoc . synifyType WithinType) ts - , ihdInstType = ClassInst $ map (unLoc . synifyType WithinType) preds + , ihdInstType = ClassInst + { clsiCtx = map (unLoc . synifyType WithinType) preds + , clsiTyVars = synifyTyVars tyvars + , clsiSigs = map (synifyIdSig WithinType) $ classMethods cls + } } where (ks,ts) = break (not . isKind) types diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 44635318..4e4d3ed9 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -264,7 +264,10 @@ renameInstHead InstHead {..} = do kinds <- mapM renameType ihdKinds types <- mapM renameType ihdTypes itype <- case ihdInstType of - ClassInst cs -> ClassInst <$> mapM renameType cs + ClassInst ctx bndrs sigs -> ClassInst + <$> mapM renameType ctx + <*> renameLTyVarBndrs bndrs + <*> mapM renameSig sigs TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd return InstHead diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c5ca31c0..0c130cb1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -324,12 +324,19 @@ instance SetName DocName where -- | The three types of instances data InstType name - = ClassInst [HsType name] -- ^ Context + = ClassInst + { clsiCtx :: [HsType name] + , clsiTyVars :: LHsTyVarBndrs name + , clsiSigs :: [Sig name] + } | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors instance OutputableBndr a => Outputable (InstType a) where - ppr (ClassInst a) = text "ClassInst" <+> ppr a + ppr (ClassInst { .. }) = text "ClassInst" + <+> ppr clsiCtx + <+> ppr clsiTyVars + <+> ppr clsiSigs ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a -- cgit v1.2.3 From dc62b95d18c61fc0bf7c8d4c49d23a240af32568 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 23 Jul 2015 19:27:24 +0200 Subject: Get rid of no longer neccessary instance specification type. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 35 +++++++++++++------------- haddock-api/src/Haddock/Types.hs | 6 ----- 2 files changed, 17 insertions(+), 24 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a894972e..34da4baa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -282,7 +282,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances links instances Nothing docname splice unicode qual + = ppInstances links instances docname splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -506,38 +506,37 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instSpec = Just $ InstSpec { ispecSigs = sigs, ispecTyVars = ltyvars } - instancesBit = ppInstances links instances instSpec nm splice unicode qual + instancesBit = ppInstances links instances nm splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo - -> [DocInstance DocName] -> Maybe (InstSpec DocName) -> DocName + -> [DocInstance DocName] -> DocName -> Splice -> Unicode -> Qualification -> Html -ppInstances links instances mspec baseName splice unicode qual +ppInstances links instances baseName splice unicode qual = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl iid (inst, maybeDoc,l) = - ((ppInstHead links splice unicode qual iid mspec inst, maybeDoc, []),l) + ((ppInstHead links splice unicode qual iid inst, maybeDoc, []),l) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> Int -> Maybe (InstSpec DocName) -> InstHead DocName + -> Int -> InstHead DocName -> Html -ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) = +ppInstHead links splice unicode qual iid (InstHead {..}) = case ihdInstType of - ClassInst cs _ _ | Just spec <- mspec -> - subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead) + ClassInst { .. } -> + subClsInstance (nameStr ++ "-" ++ show iid) hdr mets where - hdr = ppContextNoLocs cs unicode qual <+> typ + hdr = ppContextNoLocs clsiCtx unicode qual <+> typ mets = ppInstanceSigs links splice unicode qual + clsiTyVars ihdTypes clsiSigs nameStr = occNameString . nameOccName $ getName ihdClsName - ClassInst cs _ _ -> ppContextNoLocs cs unicode qual <+> typ TypeInst rhs -> keyword "type" <+> typ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs DataInst dd -> keyword "data" <+> typ @@ -547,15 +546,15 @@ ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) = ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> InstSpec DocName -> InstHead DocName + -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName] -> [Html] -ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do - TypeSig lnames (L loc typ) _ <- ispecSigs +ppInstanceSigs links splice unicode qual bndrs tys sigs = do + TypeSig lnames (L loc typ) _ <- sigs let names = map unLoc lnames - let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ + let typ' = rename' . sugar $ specializeTyVarBndrs bndrs tys typ return $ ppSimpleSig links splice unicode qual loc names typ' where - fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes + fv = foldr Set.union Set.empty . map freeVariables $ tys rename' = rename fv @@ -628,7 +627,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances links instances Nothing docname + instancesBit = ppInstances links instances docname splice unicode qual diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 0c130cb1..b4a41020 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -352,12 +352,6 @@ data InstHead name = InstHead , ihdInstType :: InstType name } --- | Instance details used for printing specialized method signatures. -data InstSpec name = InstSpec - { ispecTyVars :: LHsTyVarBndrs name - , ispecSigs :: [Sig name] - } - ----------------------------------------------------------------------------- -- * Documentation comments ----------------------------------------------------------------------------- -- cgit v1.2.3 From 17b91bbf8eea72548e58952f4969606b5cb7b73f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 23 Jul 2015 19:42:08 +0200 Subject: Fix declaration converter to use more appropriate mode for methods. --- haddock-api/src/Haddock/Convert.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3479780a..2c88dca6 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -391,16 +391,18 @@ synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name synifyInstHead (tyvars, preds, cls, types) = InstHead - { ihdClsName = getName cls - , ihdKinds = map (unLoc . synifyType WithinType) ks - , ihdTypes = map (unLoc . synifyType WithinType) ts - , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds - , clsiTyVars = synifyTyVars tyvars - , clsiSigs = map (synifyIdSig WithinType) $ classMethods cls - } - } - where (ks,ts) = break (not . isKind) types + { ihdClsName = getName cls + , ihdKinds = map (unLoc . synifyType WithinType) ks + , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdInstType = ClassInst + { clsiCtx = map (unLoc . synifyType WithinType) preds + , clsiTyVars = synifyTyVars tyvars + , clsiSigs = map synifyClsIdSig $ classMethods cls + } + } + where + (ks,ts) = break (not . isKind) types + synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) -- cgit v1.2.3 From 351eea4c53c23258d1628c91ac42d9f82e1f9c94 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 24 Jul 2015 14:51:32 +0200 Subject: Fix bug with types not being specialized at all. --- haddock-api/src/Haddock/Convert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 2c88dca6..00a90e97 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -390,13 +390,13 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (tyvars, preds, cls, types) = InstHead +synifyInstHead (_, preds, cls, types) = InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks , ihdTypes = map (unLoc . synifyType WithinType) ts , ihdInstType = ClassInst { clsiCtx = map (unLoc . synifyType WithinType) preds - , clsiTyVars = synifyTyVars tyvars + , clsiTyVars = synifyTyVars $ classTyVars cls , clsiSigs = map synifyClsIdSig $ classMethods cls } } -- cgit v1.2.3 From 131e5835425e1e411ceb5cb73f9dee855b702053 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 24 Jul 2015 15:40:32 +0200 Subject: Fix bug where instance expander was opening wrong section. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 35 ++++++++++++++++++-------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 34da4baa..a9f38c14 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -282,7 +282,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances links instances docname splice unicode qual + = ppInstances links OriginFamily instances docname splice unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -506,37 +506,41 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances links instances nm splice unicode qual + instancesBit = ppInstances links OriginClass instances nm + splice unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +data InstOrigin = OriginClass | OriginData | OriginFamily + + ppInstances :: LinksInfo - -> [DocInstance DocName] -> DocName + -> InstOrigin -> [DocInstance DocName] -> DocName -> Splice -> Unicode -> Qualification -> Html -ppInstances links instances baseName splice unicode qual +ppInstances links origin instances baseName splice unicode qual = subInstances qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) - instDecl iid (inst, maybeDoc,l) = - ((ppInstHead links splice unicode qual iid inst, maybeDoc, []),l) + instDecl no (inst, maybeDoc,l) = + ((ppInstHead links splice unicode qual origin no inst, maybeDoc, []),l) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> Int -> InstHead DocName + -> InstOrigin -> Int -> InstHead DocName -> Html -ppInstHead links splice unicode qual iid (InstHead {..}) = +ppInstHead links splice unicode qual origin no (InstHead {..}) = case ihdInstType of ClassInst { .. } -> - subClsInstance (nameStr ++ "-" ++ show iid) hdr mets + subClsInstance iid hdr mets where hdr = ppContextNoLocs clsiCtx unicode qual <+> typ mets = ppInstanceSigs links splice unicode qual clsiTyVars ihdTypes clsiSigs - nameStr = occNameString . nameOccName $ getName ihdClsName + iid = instanceId origin no ihdClsName TypeInst rhs -> keyword "type" <+> typ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs DataInst dd -> keyword "data" <+> typ @@ -562,6 +566,15 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n +instanceId :: InstOrigin -> Int -> DocName -> String +instanceId orgin no name = + qual orgin ++ ":" ++ (occNameString . getOccName) name ++ "-" ++ show no + where + qual OriginClass = "ic" + qual OriginData = "id" + qual OriginFamily = "if" + + ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- @@ -627,7 +640,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances links instances docname + instancesBit = ppInstances links OriginData instances docname splice unicode qual -- cgit v1.2.3 From a66852d67fa3a035eaa255880fb82f6f499d7e39 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 24 Jul 2015 18:40:48 +0200 Subject: Fix another type renamer bug where not all names were rebound. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 78af98b8..38ec7d44 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -299,7 +299,7 @@ rebindName name = do case Map.lookup (getName name) rneCtx of Just name' -> pure name' Nothing | getNameRep name `Set.member` rneFV -> freshName name - Nothing -> pure name + Nothing -> reuseName name -- | Generate fresh occurrence name, put it into context and return. @@ -316,6 +316,13 @@ freshName name = do rep = getNameRep nname +reuseName :: SetName name => name -> Rebind name name +reuseName name = do + env@RenameEnv { .. } <- get + put $ env { rneCtx = Map.insert (getName name) name rneCtx } + return name + + findFreshName :: Set NameRep -> NameRep -> NameRep findFreshName taken = fromJust . List.find isFresh . alternativeNames -- cgit v1.2.3 From fb62902d37e9467364bbbafc9e06128be89a7277 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 24 Jul 2015 19:32:22 +0200 Subject: Fix yet another renamer bug where some names were not unique. --- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 38ec7d44..a8a4e8ec 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -296,9 +296,10 @@ rebindTyVarBndr (KindedTyVar name kinds) = rebindName :: SetName name => name -> Rebind name name rebindName name = do RenameEnv { .. } <- get + taken <- takenNames case Map.lookup (getName name) rneCtx of Just name' -> pure name' - Nothing | getNameRep name `Set.member` rneFV -> freshName name + Nothing | getNameRep name `Set.member` taken -> freshName name Nothing -> reuseName name @@ -306,12 +307,11 @@ rebindName name = do freshName :: SetName name => name -> Rebind name name freshName name = do env@RenameEnv { .. } <- get - let taken = Set.union rneFV (elems' rneCtx) + taken <- takenNames let name' = setInternalNameRep (findFreshName taken rep) name put $ env { rneCtx = Map.insert nname name' rneCtx } return name' where - elems' = Set.fromList . map getNameRep . Map.elems nname = getName name rep = getNameRep nname @@ -323,6 +323,14 @@ reuseName name = do return name +takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames = do + RenameEnv { .. } <- get + return $ Set.union rneFV (ctxElems rneCtx) + where + ctxElems = Set.fromList . map getNameRep . Map.elems + + findFreshName :: Set NameRep -> NameRep -> NameRep findFreshName taken = fromJust . List.find isFresh . alternativeNames -- cgit v1.2.3 From f0a5efd72072b37a2150efd281eb158033e67585 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 28 Jul 2015 23:34:03 +0200 Subject: Split instance subsection layout method to top-level declarations. --- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 27 +++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 460cc6d7..da03985e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -206,12 +206,29 @@ subClsInstance :: String -- ^ Section unique id -> Html -- ^ Header contents (instance name and type) -> [Html] -- ^ Method contents (pretty-printed signatures) -> Html -subClsInstance sid hdr mets = - (hdrDiv << hdr) <+> (methodDiv << subBlock mets) +subClsInstance iid hdr mets = subInstHead iid hdr <+> subInstMethods iid mets + + +subInstHead :: String -- ^ Instance unique id (for anchor generation) + -> Html -- ^ Header content (instance name and type) + -> Html +subInstHead iid hdr = + expander << hdr where - anchorId = makeAnchorId $ "i:" ++ sid - hdrDiv = thediv ! collapseControl anchorId False "instance" - methodDiv = thediv ! collapseSection anchorId False "methods" + expander = thediv ! collapseControl (instAnchorId iid) False "instance" + + +subInstMethods :: String -- ^ Instance unique id (for anchor generation) + -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html +subInstMethods iid mets = + section << subBlock mets + where + section = thediv ! collapseSection (instAnchorId iid) False "methods" + + +instAnchorId :: String -> String +instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html -- cgit v1.2.3 From 88df578a8573908d665d4597c4c619c29055a277 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 28 Jul 2015 23:58:13 +0200 Subject: Rearrange layout of instance methods in generated documentation. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 39 ++++++++++++++++-------- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a9f38c14..abcf3eaf 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -525,26 +525,39 @@ ppInstances links origin instances baseName splice unicode qual where instName = getOccString $ getName baseName instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) - instDecl no (inst, maybeDoc,l) = - ((ppInstHead links splice unicode qual origin no inst, maybeDoc, []),l) + instDecl no (inst, mdoc, loc) = + ((ppInstHead links splice unicode qual mdoc origin no inst), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> InstOrigin -> Int -> InstHead DocName - -> Html -ppInstHead links splice unicode qual origin no (InstHead {..}) = + -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName + -> SubDecl +ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = case ihdInstType of ClassInst { .. } -> - subClsInstance iid hdr mets + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + , mdoc + , [subInstMethods iid sigs] + ) where - hdr = ppContextNoLocs clsiCtx unicode qual <+> typ - mets = ppInstanceSigs links splice unicode qual - clsiTyVars ihdTypes clsiSigs iid = instanceId origin no ihdClsName - TypeInst rhs -> keyword "type" <+> typ - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - DataInst dd -> keyword "data" <+> typ - <+> ppShortDataDecl False True dd unicode qual + sigs = ppInstanceSigs links splice unicode qual + clsiTyVars ihdTypes clsiSigs + TypeInst rhs -> + (ptype, mdoc, []) + where + ptype = mconcat + [ keyword "type" + , typ + , maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + ] + DataInst dd -> + (pdata, mdoc, []) + where + pdata = mconcat + [ keyword "data" <+> typ + , ppShortDataDecl False True dd unicode qual + ] where typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index da03985e..0b09e220 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, subClsInstance, + subInstances, subClsInstance, subInstHead, subInstMethods, subMethods, subMinimal, -- cgit v1.2.3 From 17e6df0835457035c7837e6d3f149bb3d448e5d7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 00:01:56 +0200 Subject: Get rid of no longer used layout method. --- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 0b09e220..a1c54c99 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, subClsInstance, subInstHead, subInstMethods, + subInstances, subInstHead, subInstMethods, subMethods, subMinimal, @@ -200,15 +200,7 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm - --- | Generate class instance div with specialized methods. -subClsInstance :: String -- ^ Section unique id - -> Html -- ^ Header contents (instance name and type) - -> [Html] -- ^ Method contents (pretty-printed signatures) - -> Html -subClsInstance iid hdr mets = subInstHead iid hdr <+> subInstMethods iid mets - - + subInstHead :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) -> Html -- cgit v1.2.3 From 467b07ecf9b22e3492b014dbae64f2f7d9b73f02 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 00:23:36 +0200 Subject: Attach section title to the instance methods block. --- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index a1c54c99..117f8fc8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -214,7 +214,7 @@ subInstMethods :: String -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Method contents (pretty-printed signatures) -> Html subInstMethods iid mets = - section << subBlock mets + section << subMethods mets where section = thediv ! collapseSection (instAnchorId iid) False "methods" -- cgit v1.2.3 From 3827f2557a52c78ead03350d9e8576278b649745 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 09:37:41 +0200 Subject: Add basic tests for associated types in instances test case. --- html-test/src/Instances.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/html-test/src/Instances.hs b/html-test/src/Instances.hs index 58bdc873..b7bc8921 100644 --- a/html-test/src/Instances.hs +++ b/html-test/src/Instances.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeFamilies #-} module Instances where @@ -63,3 +64,30 @@ data Quux a b c = Qx a | Qux a b | Quux a b c instance Foo (Quux a b) instance Bar (Quux a c) (Quux a b c) instance Baz (Quux a b c) + + +class Norf a b where + + type Plugh a c b + data Thud a c + + norf :: Plugh a c b -> a -> (a -> c) -> b + + norf = undefined + + +instance Norf Int Bool where + + type Plugh Int [a] Bool = a + type Plugh Int (a, b) Bool = (a, [b]) + + data Thud Int (Quux a [a] c) = Thuud a | Thuuud Int Int + data Thud Int [a] = Thuuuud Bool + + +instance Norf [a] [b] where + + type Plugh [a] (Maybe a) [b] = a + type Plugh [a] [b] [b] = Quux a b (a, b) + + data Thud [a] (a, a, a) = Thd a -- cgit v1.2.3 From 0c34ec0ae515d88437e04a49ca0131205be096e5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 12:07:13 +0200 Subject: Attach associated types information to instance header. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 3 +++ haddock-api/src/Haddock/Interface/Rename.hs | 9 +++++---- haddock-api/src/Haddock/Types.hs | 1 + 4 files changed, 10 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 47087911..24779a94 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -562,7 +562,7 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead ppInstHead :: Bool -> InstHead DocName -> LaTeX ppInstHead unicode (InstHead {..}) = case ihdInstType of - ClassInst ctx _ _ -> ppContextNoLocs ctx unicode <+> typ + ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs DataInst _ -> error "data instances not supported by --latex yet" where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 00a90e97..a2716d92 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -398,6 +398,9 @@ synifyInstHead (_, preds, cls, types) = InstHead { clsiCtx = map (unLoc . synifyType WithinType) preds , clsiTyVars = synifyTyVars $ classTyVars cls , clsiSigs = map synifyClsIdSig $ classMethods cls + , clsiAssocTys = do + (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + pure fam } } where diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 4e4d3ed9..82d14a2c 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -264,10 +264,11 @@ renameInstHead InstHead {..} = do kinds <- mapM renameType ihdKinds types <- mapM renameType ihdTypes itype <- case ihdInstType of - ClassInst ctx bndrs sigs -> ClassInst - <$> mapM renameType ctx - <*> renameLTyVarBndrs bndrs - <*> mapM renameSig sigs + ClassInst { .. } -> ClassInst + <$> mapM renameType clsiCtx + <*> renameLTyVarBndrs clsiTyVars + <*> mapM renameSig clsiSigs + <*> mapM renameFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd return InstHead diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4a41020..ac073036 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -328,6 +328,7 @@ data InstType name { clsiCtx :: [HsType name] , clsiTyVars :: LHsTyVarBndrs name , clsiSigs :: [Sig name] + , clsiAssocTys :: [FamilyDecl name] } | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -- cgit v1.2.3 From 73f4a18d0b29dd209a5f1172c8ed662be11d5690 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 12:25:54 +0200 Subject: Make instance details section contain associated types information. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 ++++++++++++- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 11 ++++++----- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index abcf3eaf..6fb36e29 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -537,12 +537,14 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ , mdoc - , [subInstMethods iid sigs] + , [subInstDetails iid ats sigs] ) where iid = instanceId origin no ihdClsName sigs = ppInstanceSigs links splice unicode qual clsiTyVars ihdTypes clsiSigs + ats = ppInstanceAssocTys links splice unicode qual + clsiAssocTys TypeInst rhs -> (ptype, mdoc, []) where @@ -562,6 +564,15 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual +ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> [FamilyDecl DocName] + -> [Html] +ppInstanceAssocTys links splice unicode qual = + map ppTyFam' + where + ppTyFam' fam = ppTyFamHeader False True fam unicode qual + + ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName] -> [Html] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 117f8fc8..074b6801 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, subInstHead, subInstMethods, + subInstances, subInstHead, subInstDetails, subMethods, subMinimal, @@ -210,13 +210,14 @@ subInstHead iid hdr = expander = thediv ! collapseControl (instAnchorId iid) False "instance" -subInstMethods :: String -- ^ Instance unique id (for anchor generation) +subInstDetails :: String -- ^ Instance unique id (for anchor generation) + -> [Html] -- ^ Associated type contents -> [Html] -- ^ Method contents (pretty-printed signatures) -> Html -subInstMethods iid mets = - section << subMethods mets +subInstDetails iid ats mets = + section << (subAssociatedTypes ats <+> subMethods mets) where - section = thediv ! collapseSection (instAnchorId iid) False "methods" + section = thediv ! collapseSection (instAnchorId iid) False "inst-details" instAnchorId :: String -> String -- cgit v1.2.3 From 3fb4ec56a9e7fc167c8fd970bc15b554ab85a1c9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 12:50:51 +0200 Subject: Improve look of rendered associated families in instance details. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 6fb36e29..4b28e4ff 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -302,6 +302,15 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual +ppSimpleAssocTy :: LinksInfo -> Splice -> Unicode -> Qualification + -> FamilyDecl DocName + -> Html +ppSimpleAssocTy links splice unicode qual decl = + ppAssocType False links noDocForDecl ldecl [] splice unicode qual + where + ldecl = L (getLoc $ fdLName decl) decl + + -------------------------------------------------------------------------------- -- * TyClDecl helpers -------------------------------------------------------------------------------- @@ -568,9 +577,9 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -> [FamilyDecl DocName] -> [Html] ppInstanceAssocTys links splice unicode qual = - map ppTyFam' + map ppSimpleAssocTy' where - ppTyFam' fam = ppTyFamHeader False True fam unicode qual + ppSimpleAssocTy' = ppSimpleAssocTy links splice unicode qual ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -- cgit v1.2.3 From de395700afa73065a2ec69ba5e3cc3ec1a474d11 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 15:13:26 +0200 Subject: Introduce alternative type for family declarations. --- haddock-api/src/Haddock/Types.hs | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ac073036..90672c9d 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -341,6 +341,37 @@ instance OutputableBndr a => Outputable (InstType a) where ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a + +-- | Almost the same as 'FamilyDecl' except for type binders. +-- +-- In order to perform type specialization for class instances, we need to +-- substitute class variables to appropriate type. However, type variables in +-- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'. +-- This makes type substitution impossible and to overcome this issue, +-- 'PseudoFamilyDecl' type is introduced. +data PseudoFamilyDecl name = PseudoFamilyDecl + { pfdInfo :: FamilyInfo name + , pfdLName :: Located name + , pfdTyVars :: [LHsType name] + , pfdKindSig :: Maybe (LHsKind name) + } + + +mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name +mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl + { pfdInfo = fdInfo + , pfdLName = fdLName + , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ] + , pfdKindSig = fdKindSig + } + where + mkType (KindedTyVar (L loc name) lkind) = + HsKindSig tvar lkind + where + tvar = L loc (HsTyVar name) + mkType (UserTyVar name) = HsTyVar name + + -- | An instance head that may have documentation and a source location. type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- cgit v1.2.3 From 3073526a26d013e8751068fbd526974dcfb8259f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 15:37:48 +0200 Subject: Make instance details record use new type for family declarations. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 +++++++++++------------ haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 12 +++++++++++- haddock-api/src/Haddock/Types.hs | 2 +- 4 files changed, 24 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4b28e4ff..eb4524c2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -291,6 +291,14 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] ) + + +ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification + -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyDecl = undefined + + -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -302,15 +310,6 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual -ppSimpleAssocTy :: LinksInfo -> Splice -> Unicode -> Qualification - -> FamilyDecl DocName - -> Html -ppSimpleAssocTy links splice unicode qual decl = - ppAssocType False links noDocForDecl ldecl [] splice unicode qual - where - ldecl = L (getLoc $ fdLName decl) decl - - -------------------------------------------------------------------------------- -- * TyClDecl helpers -------------------------------------------------------------------------------- @@ -574,12 +573,12 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> [FamilyDecl DocName] + -> [PseudoFamilyDecl DocName] -> [Html] ppInstanceAssocTys links splice unicode qual = - map ppSimpleAssocTy' + map ppFamilyDecl' where - ppSimpleAssocTy' = ppSimpleAssocTy links splice unicode qual + ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a2716d92..095bd9e0 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -400,7 +400,7 @@ synifyInstHead (_, preds, cls, types) = InstHead , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls - pure fam + pure $ mkPseudoFamilyDecl fam } } where diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 82d14a2c..146a7c0b 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -268,7 +268,7 @@ renameInstHead InstHead {..} = do <$> mapM renameType clsiCtx <*> renameLTyVarBndrs clsiTyVars <*> mapM renameSig clsiSigs - <*> mapM renameFamilyDecl clsiAssocTys + <*> mapM renamePseudoFamilyDecl clsiAssocTys TypeInst ts -> TypeInst <$> traverse renameType ts DataInst dd -> DataInst <$> renameTyClD dd return InstHead @@ -352,6 +352,16 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname return (FamilyDecl { fdInfo = info', fdLName = lname' , fdTyVars = ltyvars', fdKindSig = tckind' }) + +renamePseudoFamilyDecl :: PseudoFamilyDecl Name + -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl + <$> renameFamilyInfo pfdInfo + <*> renameL pfdLName + <*> mapM renameLType pfdTyVars + <*> renameMaybeLKind pfdKindSig + + renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 90672c9d..1f074ac3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -328,7 +328,7 @@ data InstType name { clsiCtx :: [HsType name] , clsiTyVars :: LHsTyVarBndrs name , clsiSigs :: [Sig name] - , clsiAssocTys :: [FamilyDecl name] + , clsiAssocTys :: [PseudoFamilyDecl name] } | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -- cgit v1.2.3 From 5980cfb8eb5bf86e420c2d1b82d6d3b92c0c1fda Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 16:51:22 +0200 Subject: Split printer of type family header to separate functions. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 37 ++++++++++++++------------ 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index eb4524c2..e248dc25 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -239,28 +239,31 @@ ppSimpleSig links splice unicode qual loc names typ = -------------------------------------------------------------------------------- +ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo assoc OpenTypeFamily + | assoc = keyword "type" + | otherwise = keyword "type family" +ppFamilyInfo assoc DataFamily + | assoc = keyword "data" + | otherwise = keyword "data family" +ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" + + +ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html +ppFamilyKind unicode qual (Just kind) = + dcolon unicode <+> ppLKind unicode qual kind +ppFamilyKind _ _ Nothing = noHtml + + ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info , fdKindSig = mkind }) unicode qual = - (case info of - OpenTypeFamily - | associated -> keyword "type" - | otherwise -> keyword "type family" - DataFamily - | associated -> keyword "data" - | otherwise -> keyword "data family" - ClosedTypeFamily _ - -> keyword "type family" - ) <+> - - ppFamDeclBinderWithVars summary d <+> - - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml - ) + ppFamilyInfo associated info <+> + ppFamDeclBinderWithVars summary d <+> + ppFamilyKind unicode qual mkind + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> -- cgit v1.2.3 From 709ce61f4cf18b2d6a24411670713d7480b8218c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 17:45:00 +0200 Subject: Implement HTML renderer for pseudo-family declarations. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e248dc25..e6869916 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -265,6 +265,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ppFamilyKind unicode qual mkind +ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName + -> Html +ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = + ppFamilyInfo True pfdInfo <+> + ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppFamilyKind unicode qual pfdKindSig + + ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html @@ -299,7 +307,11 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification -> PseudoFamilyDecl DocName -> Html -ppPseudoFamilyDecl = undefined +ppPseudoFamilyDecl links splice unicode qual + decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = + wrapper $ ppPseudoFamilyHeader unicode qual decl + where + wrapper = topDeclElem links loc splice [name] -------------------------------------------------------------------------------- -- cgit v1.2.3 From 00571a39acaa5aaa292b5a4bd5c17f122951f7ae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 18:21:04 +0200 Subject: Apply type specializer to associated type family declarations. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++--- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 14 +++++++++++++- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e6869916..294af864 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -567,7 +567,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = sigs = ppInstanceSigs links splice unicode qual clsiTyVars ihdTypes clsiSigs ats = ppInstanceAssocTys links splice unicode qual - clsiAssocTys + clsiTyVars ihdTypes clsiAssocTys TypeInst rhs -> (ptype, mdoc, []) where @@ -588,10 +588,11 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> LHsTyVarBndrs DocName -> [HsType DocName] -> [PseudoFamilyDecl DocName] -> [Html] -ppInstanceAssocTys links splice unicode qual = - map ppFamilyDecl' +ppInstanceAssocTys links splice unicode qual bndrs tys = + map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys) where ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a8a4e8ec..109788fd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -7,6 +7,7 @@ module Haddock.Backends.Xhtml.Specialize ( specialize, specialize' , specializeTyVarBndrs + , specializePseudoFamilyDecl , sugar, rename , freeVariables ) where @@ -58,8 +59,9 @@ specialize' = flip $ foldr (uncurry specialize) -- 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 :: (Eq name, Typeable name, DataId name) + => Data a => LHsTyVarBndrs name -> [HsType name] - -> HsType name -> HsType name + -> a -> a specializeTyVarBndrs bndrs typs = specialize' $ zip bndrs' typs where @@ -68,6 +70,16 @@ specializeTyVarBndrs bndrs typs = bname (KindedTyVar (L _ name) _) = name +specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) + => LHsTyVarBndrs name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name +specializePseudoFamilyDecl bndrs typs decl = + decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } + where + specializeTyVars = specializeTyVarBndrs bndrs typs + + -- | Make given type use tuple and list literals where appropriate. -- -- After applying 'specialize' function some terms may not use idiomatic list -- cgit v1.2.3 From 730d8b0e76c5e637f2cdd7d980865f6208729366 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 18:43:39 +0200 Subject: Create helper method for specializing type signatures. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 9 ++------- haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 18 +++++++++++++----- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 294af864..7255bf42 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -31,7 +31,6 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map -import qualified Data.Set as Set import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) @@ -601,13 +600,9 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName] -> [Html] ppInstanceSigs links splice unicode qual bndrs tys sigs = do - TypeSig lnames (L loc typ) _ <- sigs + TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs let names = map unLoc lnames - let typ' = rename' . sugar $ specializeTyVarBndrs bndrs tys typ - return $ ppSimpleSig links splice unicode qual loc names typ' - where - fv = foldr Set.union Set.empty . map freeVariables $ tys - rename' = rename fv + return $ ppSimpleSig links splice unicode qual loc names typ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index 109788fd..2295605b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -5,11 +5,7 @@ module Haddock.Backends.Xhtml.Specialize - ( specialize, specialize' - , specializeTyVarBndrs - , specializePseudoFamilyDecl - , sugar, rename - , freeVariables + ( specializePseudoFamilyDecl, specializeSig ) where @@ -80,6 +76,18 @@ specializePseudoFamilyDecl bndrs typs decl = specializeTyVars = specializeTyVarBndrs bndrs typs +specializeSig :: (Eq name, Typeable name, DataId name, SetName name) + => LHsTyVarBndrs name -> [HsType name] + -> Sig name + -> Sig name +specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = + TypeSig lnames (L loc typ') prn + where + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ + fv = foldr Set.union Set.empty . map freeVariables $ typs +specializeSig _ _ sig = sig + + -- | Make given type use tuple and list literals where appropriate. -- -- After applying 'specialize' function some terms may not use idiomatic list -- cgit v1.2.3 From f0222eaf888dafb9fdb6dbbac0527fc28223588d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 19:32:32 +0200 Subject: Refactor specializer module to be independent from XHTML backend. --- haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 +- .../src/Haddock/Backends/Xhtml/Specialize.hs | 382 -------------------- haddock-api/src/Haddock/Convert.hs | 6 +- haddock-api/src/Haddock/Interface/Specialize.hs | 396 +++++++++++++++++++++ haddock.cabal | 2 +- 6 files changed, 409 insertions(+), 397 deletions(-) delete mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs create mode 100644 haddock-api/src/Haddock/Interface/Specialize.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 2090c53e..b4ceb1a0 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -69,6 +69,7 @@ library Haddock.Interface.AttachInstances Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader + Haddock.Interface.Specialize Haddock.Parser Haddock.Utils Haddock.Backends.Xhtml @@ -76,7 +77,6 @@ library Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout Haddock.Backends.Xhtml.Names - Haddock.Backends.Xhtml.Specialize Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7255bf42..7da1f08e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -22,7 +22,6 @@ module Haddock.Backends.Xhtml.Decl ( import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Specialize import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils @@ -563,10 +562,8 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ) where iid = instanceId origin no ihdClsName - sigs = ppInstanceSigs links splice unicode qual - clsiTyVars ihdTypes clsiSigs - ats = ppInstanceAssocTys links splice unicode qual - clsiTyVars ihdTypes clsiAssocTys + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> (ptype, mdoc, []) where @@ -587,20 +584,19 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> LHsTyVarBndrs DocName -> [HsType DocName] -> [PseudoFamilyDecl DocName] -> [Html] -ppInstanceAssocTys links splice unicode qual bndrs tys = - map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys) +ppInstanceAssocTys links splice unicode qual = + map ppFamilyDecl' where ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName] + -> [Sig DocName] -> [Html] -ppInstanceSigs links splice unicode qual bndrs tys sigs = do - TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames (L loc typ) _ <- sigs let names = map unLoc lnames return $ ppSimpleSig links splice unicode qual loc names typ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs deleted file mode 100644 index 2295605b..00000000 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - - -module Haddock.Backends.Xhtml.Specialize - ( specializePseudoFamilyDecl, specializeSig - ) where - - -import Haddock.Syb -import Haddock.Types - -import GHC -import Name -import FastString - -import Control.Monad -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State - -import Data.Data -import qualified Data.List as List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - - --- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) - => Data a - => name -> HsType name -> a -> a -specialize name details = - everywhere $ mkT step - where - step (HsTyVar name') | name == name' = details - step typ = typ - - --- | Instantiate all occurrences of given names with corresponding types. --- --- It is just a convenience function wrapping 'specialize' that supports more --- that one specialization. -specialize' :: (Eq name, Typeable name) - => Data a - => [(name, HsType name)] -> a -> a -specialize' = flip $ foldr (uncurry specialize) - - --- | Instantiate given binders with corresponding types. --- --- Again, it is just a convenience function around 'specialize'. Note that --- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) - => Data a - => LHsTyVarBndrs name -> [HsType name] - -> a -> a -specializeTyVarBndrs bndrs typs = - specialize' $ zip bndrs' typs - where - bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs - bname (UserTyVar name) = name - bname (KindedTyVar (L _ name) _) = name - - -specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) - => LHsTyVarBndrs name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name -specializePseudoFamilyDecl bndrs typs decl = - decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } - where - specializeTyVars = specializeTyVarBndrs bndrs typs - - -specializeSig :: (Eq name, Typeable name, DataId name, SetName name) - => LHsTyVarBndrs name -> [HsType name] - -> Sig name - -> Sig name -specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = - TypeSig lnames (L loc typ') prn - where - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ - fv = foldr Set.union Set.empty . map freeVariables $ typs -specializeSig _ _ sig = sig - - --- | Make given type use tuple and list literals where appropriate. --- --- After applying 'specialize' function some terms may not use idiomatic list --- 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 name, DataId name) - => HsType name -> HsType name -sugar = - everywhere $ mkT step - where - step :: HsType name -> HsType name - step = sugarTuples . sugarLists - - -sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' -sugarLists typ = typ - - -sugarTuples :: NamedThing name => HsType name -> HsType name -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 name) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps - where - name' = getName name - strName = occNameString . nameOccName $ name' - suitable = case parseTupleArity strName of - Just arity -> arity == length apps - Nothing -> False - aux _ _ = typ - - --- | Compute arity of given tuple operator. --- --- >>> parseTupleArity "(,,)" --- Just 3 --- --- >>> parseTupleArity "(,,,,)" --- Just 5 --- --- >>> parseTupleArity "abc" --- Nothing --- --- >>> parseTupleArity "()" --- Nothing -parseTupleArity :: String -> Maybe Int -parseTupleArity ('(':commas) = do - n <- parseCommas commas - guard $ n /= 0 - return $ n + 1 - where - parseCommas (',':rest) = (+ 1) <$> parseCommas rest - parseCommas ")" = Just 0 - parseCommas _ = Nothing -parseTupleArity _ = Nothing - - --- | Haskell AST type representation. --- --- This type is used for renaming (more below), essentially the ambiguous (!) --- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, --- it was 'OccName' before, but turned out that 'OccName' sometimes also --- contains namespace information, differentiating visually same types. --- --- And 'FastString' is used because it is /visual/ part of 'OccName' - it is --- not converted to 'String' or alike to avoid new allocations. Additionally, --- since it is stored mostly in 'Set', fast comparison of 'FastString' is also --- quite nice. -type NameRep = FastString - -getNameRep :: NamedThing name => name -> NameRep -getNameRep = occNameFS . getOccName - -nameRepString :: NameRep -> String -nameRepString = unpackFS - -stringNameRep :: String -> NameRep -stringNameRep = mkFastString - -setInternalNameRep :: SetName name => NameRep -> name -> name -setInternalNameRep = setInternalOccName . mkVarOccFS - -setInternalOccName :: SetName name => OccName -> name -> name -setInternalOccName occ name = - setName nname' name - where - nname = getName name - nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) - - --- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep -freeVariables = - everythingWithState Set.empty Set.union query - where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy _ _ bndrs _ _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar name) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) - _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs - - --- | Make given type visually unambiguous. --- --- After applying 'specialize' method, some free type variables may become --- visually ambiguous - for example, having @a -> b@ and specializing @a@ to --- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to --- different type variable than latter one. Applying 'rename' function --- will fix that type to be visually unambiguous again (making it something --- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = runReader (renameType typ) $ RenameEnv - { rneFV = fv - , rneCtx = Map.empty - } - - --- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) - -data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } - - -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> - HsForAllTy - <$> pure ex - <*> pure mspan - <*> pure lbndrs' - <*> located renameContext lctx - <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> 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 (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> renameLTyOp 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 t@(HsQuasiQuoteTy _) = pure t -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 ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t -renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t -renameType HsWildcardTy = pure HsWildcardTy -renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name - - -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) -renameLType = located renameType - - -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] -renameLTypes = mapM renameLType - - -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) -renameContext = renameLTypes - - -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) -renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname - - -renameName :: SetName name => name -> Rename name name -renameName name = do - RenameEnv { rneCtx = ctx } <- ask - pure $ case Map.lookup (getName name) ctx of - Just name' -> name' - Nothing -> name - - -rebind :: SetName name - => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a) - -> Rename name a -rebind lbndrs action = do - (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask - local (const env') (action lbndrs') - - -rebindLTyVarBndrs :: SetName name - => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) -rebindLTyVarBndrs lbndrs = do - tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs - pure $ lbndrs { hsq_tvs = tys' } - - -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar name) = - UserTyVar <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName name = do - RenameEnv { .. } <- get - taken <- takenNames - case Map.lookup (getName name) rneCtx of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` taken -> freshName name - Nothing -> reuseName name - - --- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind name name -freshName name = do - env@RenameEnv { .. } <- get - taken <- takenNames - let name' = setInternalNameRep (findFreshName taken rep) name - put $ env { rneCtx = Map.insert nname name' rneCtx } - return name' - where - nname = getName name - rep = getNameRep nname - - -reuseName :: SetName name => name -> Rebind name name -reuseName name = do - env@RenameEnv { .. } <- get - put $ env { rneCtx = Map.insert (getName name) name rneCtx } - return name - - -takenNames :: NamedThing name => Rebind name (Set NameRep) -takenNames = do - RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) - where - ctxElems = Set.fromList . map getNameRep . Map.elems - - -findFreshName :: Set NameRep -> NameRep -> NameRep -findFreshName taken = - fromJust . List.find isFresh . alternativeNames - where - isFresh = not . flip Set.member taken - - -alternativeNames :: NameRep -> [NameRep] -alternativeNames name - | [_] <- nameRepString name = letterNames ++ alternativeNames' name - where - letterNames = map (stringNameRep . pure) ['a'..'z'] -alternativeNames name = alternativeNames' name - - -alternativeNames' :: NameRep -> [NameRep] -alternativeNames' name = - [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] - where - str = nameRepString name - - -located :: Functor f => (a -> f b) -> Located a -> f (Located b) -located f (L loc e) = L loc <$> f e - - -tyVarName :: HsTyVarBndr name -> name -tyVarName (UserTyVar name) = name -tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 095bd9e0..c9664652 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -25,7 +25,6 @@ import Data.Either (lefts, rights) import Data.List( partition ) import DataCon import FamInstEnv -import Haddock.Types import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name @@ -41,6 +40,9 @@ import TysWiredIn ( listTyConName, eqTyCon ) import Unique ( getUnique ) import Var +import Haddock.Types +import Haddock.Interface.Specialize + -- the main function here! yay! @@ -390,7 +392,7 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = InstHead +synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks , ihdTypes = map (unLoc . synifyType WithinType) ts diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs new file mode 100644 index 00000000..df7f63bc --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Interface.Specialize + ( specializeInstHead + ) where + + +import Haddock.Syb +import Haddock.Types + +import GHC +import Name +import FastString + +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +import Data.Data +import qualified Data.List as List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +-- | Instantiate all occurrences of given name with particular type. +specialize :: (Eq name, Typeable name) + => Data a + => name -> HsType name -> a -> a +specialize name details = + everywhere $ mkT step + where + step (HsTyVar name') | name == name' = details + step typ = typ + + +-- | Instantiate all occurrences of given names with corresponding types. +-- +-- It is just a convenience function wrapping 'specialize' that supports more +-- that one specialization. +specialize' :: (Eq name, Typeable name) + => Data a + => [(name, HsType name)] -> a -> a +specialize' = flip $ foldr (uncurry specialize) + + +-- | Instantiate given binders with corresponding types. +-- +-- Again, it is just a convenience function around 'specialize'. Note that +-- length of type list should be the same as the number of binders. +specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) + => Data a + => LHsTyVarBndrs name -> [HsType name] + -> a -> a +specializeTyVarBndrs bndrs typs = + specialize' $ zip bndrs' typs + where + bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs + bname (UserTyVar name) = name + bname (KindedTyVar (L _ name) _) = name + + +specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) + => LHsTyVarBndrs name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name +specializePseudoFamilyDecl bndrs typs decl = + decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } + where + specializeTyVars = specializeTyVarBndrs bndrs typs + + +specializeSig :: (Eq name, Typeable name, DataId name, SetName name) + => LHsTyVarBndrs name -> [HsType name] + -> Sig name + -> Sig name +specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = + TypeSig lnames (L loc typ') prn + where + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ + fv = foldr Set.union Set.empty . map freeVariables $ typs +specializeSig _ _ sig = sig + + +specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name) + => InstHead name -> InstHead name +specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = + ihd { ihdInstType = instType' } + where + instType' = clsi + { clsiSigs = map specializeSig' clsiSigs + , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys + } + specializeSig' = specializeSig clsiTyVars ihdTypes + specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes +specializeInstHead ihd = ihd + + +-- | Make given type use tuple and list literals where appropriate. +-- +-- After applying 'specialize' function some terms may not use idiomatic list +-- 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 name, DataId name) + => HsType name -> HsType name +sugar = + everywhere $ mkT step + where + step :: HsType name -> HsType name + step = sugarTuples . sugarLists + + +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp + where + name' = getName name + strName = occNameString . nameOccName $ name' +sugarLists typ = typ + + +sugarTuples :: NamedThing name => HsType name -> HsType name +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 name) + | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + where + name' = getName name + strName = occNameString . nameOccName $ name' + suitable = case parseTupleArity strName of + Just arity -> arity == length apps + Nothing -> False + aux _ _ = typ + + +-- | Compute arity of given tuple operator. +-- +-- >>> parseTupleArity "(,,)" +-- Just 3 +-- +-- >>> parseTupleArity "(,,,,)" +-- Just 5 +-- +-- >>> parseTupleArity "abc" +-- Nothing +-- +-- >>> parseTupleArity "()" +-- Nothing +parseTupleArity :: String -> Maybe Int +parseTupleArity ('(':commas) = do + n <- parseCommas commas + guard $ n /= 0 + return $ n + 1 + where + parseCommas (',':rest) = (+ 1) <$> parseCommas rest + parseCommas ")" = Just 0 + parseCommas _ = Nothing +parseTupleArity _ = Nothing + + +-- | Haskell AST type representation. +-- +-- This type is used for renaming (more below), essentially the ambiguous (!) +-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, +-- it was 'OccName' before, but turned out that 'OccName' sometimes also +-- contains namespace information, differentiating visually same types. +-- +-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is +-- not converted to 'String' or alike to avoid new allocations. Additionally, +-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also +-- quite nice. +type NameRep = FastString + +getNameRep :: NamedThing name => name -> NameRep +getNameRep = occNameFS . getOccName + +nameRepString :: NameRep -> String +nameRepString = unpackFS + +stringNameRep :: String -> NameRep +stringNameRep = mkFastString + +setInternalNameRep :: SetName name => NameRep -> name -> name +setInternalNameRep = setInternalOccName . mkVarOccFS + +setInternalOccName :: SetName name => OccName -> name -> name +setInternalOccName occ name = + setName nname' name + where + nname = getName name + nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) + + +-- | Compute set of free variables of given type. +freeVariables :: forall name. (NamedThing name, DataId name) + => HsType name -> Set NameRep +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy _ _ bndrs _ _) -> + (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsTyVar name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getNameRep name, ctx) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + + +-- | Make given type visually unambiguous. +-- +-- After applying 'specialize' method, some free type variables may become +-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to +-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to +-- different type variable than latter one. Applying 'rename' function +-- will fix that type to be visually unambiguous again (making it something +-- like @(a -> c) -> b@). +rename :: SetName name => Set NameRep -> HsType name -> HsType name +rename fv typ = runReader (renameType typ) $ RenameEnv + { rneFV = fv + , rneCtx = Map.empty + } + + +-- | Renaming monad. +type Rename name = Reader (RenameEnv name) + +-- | Binding generation monad. +type Rebind name = State (RenameEnv name) + +data RenameEnv name = RenameEnv + { rneFV :: Set NameRep + , rneCtx :: Map Name name + } + + +renameType :: SetName name => HsType name -> Rename name (HsType name) +renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> + HsForAllTy + <$> pure ex + <*> pure mspan + <*> pure lbndrs' + <*> located renameContext lctx + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> 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 (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> renameLTyOp 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 t@(HsQuasiQuoteTy _) = pure t +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 ph ltys) = + HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> renameLTypes ltys +renameType t@(HsTyLit _) = pure t +renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t +renameType HsWildcardTy = pure HsWildcardTy +renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name + + +renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType = located renameType + + +renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes = mapM renameLType + + +renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext = renameLTypes + + +renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) +renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname + + +renameName :: SetName name => name -> Rename name name +renameName name = do + RenameEnv { rneCtx = ctx } <- ask + pure $ case Map.lookup (getName name) ctx of + Just name' -> name' + Nothing -> name + + +rebind :: SetName name + => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a) + -> Rename name a +rebind lbndrs action = do + (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask + local (const env') (action lbndrs') + + +rebindLTyVarBndrs :: SetName name + => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) +rebindLTyVarBndrs lbndrs = do + tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs + pure $ lbndrs { hsq_tvs = tys' } + + +rebindTyVarBndr :: SetName name + => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) +rebindTyVarBndr (UserTyVar name) = + UserTyVar <$> rebindName name +rebindTyVarBndr (KindedTyVar name kinds) = + KindedTyVar <$> located rebindName name <*> pure kinds + + +rebindName :: SetName name => name -> Rebind name name +rebindName name = do + RenameEnv { .. } <- get + taken <- takenNames + case Map.lookup (getName name) rneCtx of + Just name' -> pure name' + Nothing | getNameRep name `Set.member` taken -> freshName name + Nothing -> reuseName name + + +-- | Generate fresh occurrence name, put it into context and return. +freshName :: SetName name => name -> Rebind name name +freshName name = do + env@RenameEnv { .. } <- get + taken <- takenNames + let name' = setInternalNameRep (findFreshName taken rep) name + put $ env { rneCtx = Map.insert nname name' rneCtx } + return name' + where + nname = getName name + rep = getNameRep nname + + +reuseName :: SetName name => name -> Rebind name name +reuseName name = do + env@RenameEnv { .. } <- get + put $ env { rneCtx = Map.insert (getName name) name rneCtx } + return name + + +takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames = do + RenameEnv { .. } <- get + return $ Set.union rneFV (ctxElems rneCtx) + where + ctxElems = Set.fromList . map getNameRep . Map.elems + + +findFreshName :: Set NameRep -> NameRep -> NameRep +findFreshName taken = + fromJust . List.find isFresh . alternativeNames + where + isFresh = not . flip Set.member taken + + +alternativeNames :: NameRep -> [NameRep] +alternativeNames name + | [_] <- nameRepString name = letterNames ++ alternativeNames' name + where + letterNames = map (stringNameRep . pure) ['a'..'z'] +alternativeNames name = alternativeNames' name + + +alternativeNames' :: NameRep -> [NameRep] +alternativeNames' name = + [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] + where + str = nameRepString name + + +located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr name -> name +tyVarName (UserTyVar name) = name +tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock.cabal b/haddock.cabal index 4ea2a82a..71b78347 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -90,6 +90,7 @@ executable haddock Haddock.Interface.AttachInstances Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader + Haddock.Interface.Specialize Haddock.Parser Haddock.Utils Haddock.Backends.Xhtml @@ -97,7 +98,6 @@ executable haddock Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout Haddock.Backends.Xhtml.Names - Haddock.Backends.Xhtml.Specialize Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils -- cgit v1.2.3 From e3b0be8daf6f9fc8adad3d858f80187d3de74876 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 19:45:15 +0200 Subject: Add some documentation for instance head specializer. --- haddock-api/src/Haddock/Interface/Specialize.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index df7f63bc..59985de6 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -88,6 +88,8 @@ specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = specializeSig _ _ sig = sig +-- | Make all details of instance head (signatures, associated types) +-- specialized to that particular instance type. specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = -- cgit v1.2.3 From ca667e192d0867c9c2a3025918414147f50b7c19 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 31 Jul 2015 12:38:59 +0200 Subject: Fix bug with missing space in documentation for associated types. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7da1f08e..af946f9f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -567,18 +567,13 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = TypeInst rhs -> (ptype, mdoc, []) where - ptype = mconcat - [ keyword "type" - , typ - , maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - ] + ptype = keyword "type" <+> typ <+> prhs + prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs DataInst dd -> (pdata, mdoc, []) where - pdata = mconcat - [ keyword "data" <+> typ - , ppShortDataDecl False True dd unicode qual - ] + pdata = keyword "data" <+> typ <+> pdecl + pdecl = ppShortDataDecl False True dd unicode qual where typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual -- cgit v1.2.3 From a49a3f0840f2880814c35f58d89805b3cd3039d3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 31 Jul 2015 16:24:36 +0200 Subject: Fix issue with incorrect instance details sections being expanded. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 39 ++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index af946f9f..35e5c5f6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -26,8 +27,11 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types +import Haddock.Syb import Haddock.Doc (combineDocumentation) +import Data.Bits +import Data.Data (Data, cast) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -35,6 +39,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import GHC import GHC.Exts +import Unique import Name import BooleanFormula @@ -553,7 +558,7 @@ ppInstances links origin instances baseName splice unicode qual ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName -> SubDecl -ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = +ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ @@ -561,7 +566,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = , [subInstDetails iid ats sigs] ) where - iid = instanceId origin no ihdClsName + iid = instanceId origin no ihd sigs = ppInstanceSigs links splice unicode qual clsiSigs ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> @@ -600,15 +605,39 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin -> Int -> DocName -> String -instanceId orgin no name = - qual orgin ++ ":" ++ (occNameString . getOccName) name ++ "-" ++ show no +instanceId :: InstOrigin -> Int -> InstHead DocName -> String +instanceId orgin no ihd = concat + [ qual orgin + , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , "-" ++ show (instHeadId ihd) + , "-" ++ show no + ] where qual OriginClass = "ic" qual OriginData = "id" qual OriginFamily = "if" +-- | Compute unique identifier for given instance. +-- +-- This is rather poor way of doing it. Ideally, we would like to have +-- everything wrapped in a stateful monad that allows us to generate unique +-- identifiers as needed. Since introducing such monad would require major +-- refactoring, for now we just generate naive hash for given instance. +-- +-- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea +-- for such simple hash function is stolen from +-- . +instHeadId :: InstHead DocName -> Int +instHeadId (InstHead { .. }) = + djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds + where + names = everything (++) $ + maybeToList . (cast :: forall a. Data a => a -> Maybe DocName) + djb2 = foldl (\h c -> h * 33 `xor` c) 5381 + key = getKey . nameUnique . getName + + ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- -- cgit v1.2.3 From 0158692153c342eb84879338aeb99a6bb0221889 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 31 Jul 2015 17:05:48 +0200 Subject: Accept tests affected by adding instance details section. --- html-test/ref/Bug26.html | 22 +- html-test/ref/Bug7.html | 40 ++-- html-test/ref/Hash.html | 88 ++++++-- html-test/ref/HiddenInstances.html | 130 ++++++++++-- html-test/ref/HiddenInstancesB.html | 32 ++- html-test/ref/QuasiExpr.html | 92 +++++++- html-test/ref/SpuriousSuperclassConstraints.html | 100 +++++++-- html-test/ref/Test.html | 72 ++++++- html-test/ref/TypeFamilies.html | 256 ++++++++++++++++++----- html-test/ref/ocean.css | 14 +- 10 files changed, 712 insertions(+), 134 deletions(-) diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index 8b9e5a7b..e56d3821 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -147,9 +147,11 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug26.html");}; >
    C ()
    C ()

    Methods

    c_f :: ()

    Bar Foo Foo
    Bar Foo Foo
    		Just one instance

    Bar Foo Foo
    Bar Foo Foo
    		Just one instance

    Hash Float
    Hash Float
    		 

    Methods

    hash :: Float -> Int

    Hash Int
    Hash Int
    		 

    Methods

    hash :: Int -> Int

    (Hash a, Hash b) => Hash (a, b)
    (Hash a, Hash b) => Hash (a, b)
    		 

    Methods

    hash :: (a, b) -> Int

    VisibleClass Int
    VisibleClass Int
    VisibleClass VisibleData
    VisibleClass VisibleData
    		Should be visible

    Num VisibleData
    VisibleClass VisibleData
    VisibleClass VisibleData
    		Should be visible

    Foo Bar
    Foo Bar
    		Should be visible

    Foo Bar
    Foo Bar
    		Should be visible

    Show Expr 

    Methods

    showsPrec :: Int -> Expr -> ShowS

    show :: Expr -> String

    showList :: [Expr] -> ShowS

    Show BinOp 

    Methods

    showsPrec :: Int -> BinOp -> ShowS

    show :: BinOp -> String

    showList :: [BinOp] -> ShowS

    Functor (SomeType f) 

    Methods

    fmap :: (a -> b) -> SomeType f a -> SomeType f b

    (<$) :: a -> SomeType f b -> SomeType f a

    Applicative f => Applicative (SomeType f) 

    Methods

    pure :: a -> SomeType f a

    (<*>) :: SomeType f (a -> b) -> SomeType f a -> SomeType f b

    (*>) :: SomeType f a -> SomeType f b -> SomeType f b

    (<*) :: SomeType f a -> SomeType f b -> SomeType f a

    D Float
    D Float
    		 

    Methods

    d :: T Float b

    e :: (Float, Float)

    D Int
    D Int
    		 

    Methods

    d :: T Int b

    e :: (Int, Int)

    Assoc * X
    Assoc * X

    Associated Types

    data AssocD (X :: k)

    type AssocT (X :: k) :: *

    Test * X
    Test * X
    (><) X XX XXX
    (><) X XX XXX
    		 
    Assoc * Y
    Assoc * Y

    Associated Types

    data AssocD (Y :: k)

    type AssocT (Y :: k) :: *

    Test * Y
    Test * Y
    Test * Y
    Test * Y
    Test * X
    Test * X
    		Doc for: instance Test X

    Assoc * Y
    Assoc * Y

    Associated Types

    data AssocD (Y :: k)

    type AssocT (Y :: k) :: *

    Assoc * X
    Assoc * X
    		Doc for: instance Assoc X

    Associated Types

    data AssocD (X :: k)

    type AssocT (X :: k) :: *

    (><) X XX XXX
    (><) X XX XXX
    		 
    Date: Fri, 31 Jul 2015 18:24:40 +0200 Subject: Make section identifier of instance details more GHC-independent. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 35e5c5f6..c30d0e62 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,7 +39,6 @@ import Text.XHtml hiding ( name, title, p, quote ) import GHC import GHC.Exts -import Unique import Name import BooleanFormula @@ -609,8 +608,8 @@ instanceId :: InstOrigin -> Int -> InstHead DocName -> String instanceId orgin no ihd = concat [ qual orgin , ":" ++ (occNameString . getOccName . ihdClsName) ihd - , "-" ++ show (instHeadId ihd) - , "-" ++ show no + , ":" ++ show (instHeadId ihd) + , ":" ++ show no ] where qual OriginClass = "ic" @@ -626,16 +625,27 @@ instanceId orgin no ihd = concat -- refactoring, for now we just generate naive hash for given instance. -- -- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea --- for such simple hash function is stolen from +-- for such simple hash function (djb2) is stolen from -- . +-- +-- Hashing is performed on string representation of `Name`. Why string instead +-- of 'Unique' of that 'Name'? That would be much faster and nicer, yes. +-- However, 'Unique' is not very deterministic, so running it on different +-- configurations would yield different HTML documents. This is not very bad, +-- as nobody cares about these identifiers but it would require us to strip +-- section anchors in testing framework and that is not only inconvenient but +-- also makes testing less viable. And it is only temporary solution so we can +-- live with it. instHeadId :: InstHead DocName -> Int instHeadId (InstHead { .. }) = djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds where names = everything (++) $ maybeToList . (cast :: forall a. Data a => a -> Maybe DocName) - djb2 = foldl (\h c -> h * 33 `xor` c) 5381 - key = getKey . nameUnique . getName + key = djb2 . occNameString . nameOccName . getName + + djb2 :: Enum a => [a] -> Int + djb2 = foldl (\h c -> h * 33 `xor` fromEnum c) 5381 ------------------------------------------------------------------------------- -- cgit v1.2.3 From 6ee9d224832f5aabb1abfad0533c62ad90936624 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 31 Jul 2015 18:28:16 +0200 Subject: Re-accept tests after applying deterministic section identifiers. --- html-test/ref/Bug26.html | 4 +-- html-test/ref/Bug7.html | 8 ++--- html-test/ref/Hash.html | 12 +++---- html-test/ref/HiddenInstances.html | 16 +++++----- html-test/ref/HiddenInstancesB.html | 8 ++--- html-test/ref/QuasiExpr.html | 8 ++--- html-test/ref/SpuriousSuperclassConstraints.html | 8 ++--- html-test/ref/Test.html | 8 ++--- html-test/ref/TypeFamilies.html | 40 ++++++++++++------------ 9 files changed, 56 insertions(+), 56 deletions(-) diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index e56d3821..18bfa63b 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -147,7 +147,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug26.html");}; >
    C ()

    Methods

    Methods

    Methods

    (Hash a,

    Methods

    Methods

    Methods

    Methods

    Methods

    Methods

    D

    Methods

    D

    Methods

    Associated Types

    Test *
    (><)

    Associated Types

    Test *
    Test *
    Test *

    Associated Types

    Associated Types

    (><)

    Methods

    (Hash a,

    Methods

    Methods

    Methods

    Methods

    Methods

    D

    Methods

    Associated Types

    Test *
    (><)

    Associated Types

    Test *
    Test *
    Test *

    Associated Types

    Associated Types

    (><)
    C ()
    C ()

    Methods

    Bar Foo Foo
    Bar Foo Foo
    Hash Float

    Methods

    Hash Int

    Methods

    (Hash a, Hash b) => Hash (a, b)
    (Hash a, Hash b) => Hash (a, b)    		 

    Methods

    VisibleClass Int
    VisibleClass VisibleData
    Num VisibleData

    Methods

    VisibleClass VisibleData
    Foo Bar
    Foo Bar
    Show Expr

    Methods

    Show BinOp

    Methods

    Functor (SomeType f) 

    Methods

    Applicative f => Applicative (SomeType f) 

    Methods

    D Float

    Methods

    D Int

    Methods

    Assoc * X

    Associated Types

    Test * X
    (><) X XX XXX
    (><) X XX XXX
    Assoc * Y

    Associated Types

    Test * Y
    Test * Y
    Test * X
    Assoc * Y

    Associated Types

    Assoc * X

    Associated Types

    (><) X XX XXX
    (><) X XX XXX