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 --- haddock.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock.cabal') 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(-) (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 Haskell	None

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 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 (limited to 'haddock.cabal') 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 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(+) (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 b7fa3020ca8af55688c45a219a5418b21d91beec Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk 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(-) (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 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 (limited to 'haddock.cabal') 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 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(-) (limited to 'haddock.cabal') 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 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(-) (limited to 'haddock.cabal') 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 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(-) (limited to 'haddock.cabal') 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