From 5bd9262466a0e71da4e84654a1906b76996e3692 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Sun, 8 Aug 2021 17:19:06 +0200 Subject: coot/multiple packages (ghc-9.2) (#1418) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 137 +++++++++++++++++------ haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 7 +- haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 11 ++ 3 files changed, 116 insertions(+), 39 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d390a95a..b7674b24 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,10 +11,11 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, + ppJsonIndex ) where @@ -38,12 +39,16 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder +import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace ) +import Data.Either ( partitionEithers ) +import Data.Foldable ( traverse_) import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) import qualified System.IO as IO +import qualified System.FilePath as FilePath import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) @@ -68,6 +73,7 @@ ppHtml :: UnitState -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) + -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) @@ -79,7 +85,7 @@ ppHtml :: UnitState ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode + maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces @@ -97,12 +103,12 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug - when withQuickjump $ - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual - visible_ifaces + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual + visible_ifaces [] mapM_ (ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces @@ -119,16 +125,23 @@ copyHtmlBits odir libdir themes withQuickjump = do return () -headHtml :: String -> Themes -> Maybe String -> Html -headHtml docTitle themes mathjax_url = - header << +headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html +headHtml docTitle themes mathjax_url base_url = + header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url) + << [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle - , styleSheet themes - , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml + , styleSheet base_url themes + , thelink ! [ rel "stylesheet" + , thetype "text/css" + , href (withBaseURL base_url quickJumpCssFile) ] + << noHtml , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml - , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml + , script ! [ src (withBaseURL base_url haddockJsFile) + , emptyAttr "async" + , thetype "text/javascript" ] + << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf , script ! [src mjUrl, thetype "text/javascript"] << noHtml ] @@ -281,7 +294,7 @@ ppHtmlContents state odir doctitle _maybe_package | iface <- ifaces , instIsSig iface] html = - headHtml doctitle themes mathjax_url +++ + headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ @@ -361,6 +374,35 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = -- * Generate the index -------------------------------------------------------------------------------- +data JsonIndexEntry = JsonIndexEntry { + jieHtmlFragment :: String, + jieName :: String, + jieModule :: String, + jieLink :: String + } + deriving Show + +instance ToJSON JsonIndexEntry where + toJSON JsonIndexEntry + { jieHtmlFragment + , jieName + , jieModule + , jieLink } = + Object + [ "display_html" .= String jieHtmlFragment + , "name" .= String jieName + , "module" .= String jieModule + , "link" .= String jieLink + ] + +instance FromJSON JsonIndexEntry where + parseJSON = withObject "JsonIndexEntry" $ \v -> + JsonIndexEntry + <$> v .: "display_html" + <*> v .: "name" + <*> v .: "module" + <*> v .: "link" + ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) @@ -368,34 +410,50 @@ ppJsonIndex :: FilePath -> Maybe Package -> QualOption -> [Interface] + -> [FilePath] -- ^ file paths to interface files + -- (--read-interface) -> IO () -ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do createDirectoryIfMissing True odir - IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do - Builder.hPutBuilder h (encodeToBuilder modules) + (errors, installedIndexes) <- + partitionEithers + <$> traverse + (\ifaceFile -> + let indexFile = takeDirectory ifaceFile + FilePath. "doc-index.json" in + bimap (indexFile,) (map (fixLink ifaceFile)) + <$> eitherDecodeFile @[JsonIndexEntry] indexFile) + installedIfacesPaths + traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) + errors + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> + Builder.hPutBuilder + h (encodeToBuilder (encodeIndexes (concat installedIndexes))) where - modules :: Value - modules = Array (concatMap goInterface ifaces) - - goInterface :: Interface -> [Value] - goInterface iface = - concatMap (goExport mdl qual) (ifaceRnExportItems iface) + encodeIndexes :: [JsonIndexEntry] -> Value + encodeIndexes installedIndexes = + toJSON + (concatMap fromInterface ifaces + ++ installedIndexes) + + fromInterface :: Interface -> [JsonIndexEntry] + fromInterface iface = + mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface where aliases = ifaceModuleAliases iface qual = makeModuleQual qual_opt aliases mdl mdl = ifaceMod iface - goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] - goExport mdl qual item + mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry + mkIndex mdl qual item | Just item_html <- processExport True links_info unicode pkg qual item - = [ Object - [ "display_html" .= String (showHtmlFragment item_html) - , "name" .= String (unwords (map getOccString names)) - , "module" .= String (moduleString mdl) - , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) - ] - ] - | otherwise = [] + = Just JsonIndexEntry + { jieHtmlFragment = showHtmlFragment item_html + , jieName = unwords (map getOccString names) + , jieModule = moduleString mdl + , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + } + | otherwise = Nothing where names = exportName item ++ exportSubs item @@ -413,6 +471,13 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d links_info = (maybe_source_url, maybe_wiki_url) + -- update link using relative path to output directory + fixLink :: FilePath + -> JsonIndexEntry -> JsonIndexEntry + fixLink ifaceFile jie = + jie { jieLink = makeRelative odir (takeDirectory ifaceFile) + FilePath. jieLink jie } + ppHtmlIndex :: FilePath -> String -> Maybe String @@ -441,7 +506,7 @@ ppHtmlIndex odir doctitle _maybe_package themes where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ @@ -541,11 +606,11 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes - -> Maybe String -> SourceURLs -> WikiURLs + -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface @@ -563,7 +628,7 @@ ppHtmlModule odir doctitle themes = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str_annot themes maybe_mathjax_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index b1d64acd..08ef747a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,6 +17,7 @@ module Haddock.Backends.Xhtml.Themes ( where import Haddock.Options +import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) @@ -176,13 +177,13 @@ cssFiles :: Themes -> [String] cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: Themes -> Html -styleSheet ts = toHtml $ zipWith mkLink rels ts +styleSheet :: BaseURL -> Themes -> Html +styleSheet base_url ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (themeHref t), rel aRel, thetype "text/css", + ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index e3fd2d5a..a68cb559 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -12,6 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs, + BaseURL, + withBaseURL, LinksInfo, Splice, Unicode, @@ -20,12 +22,21 @@ module Haddock.Backends.Xhtml.Types ( import Data.Map import GHC +import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) +-- | base url for loading js, json, css resources. The default is "." +-- +type BaseURL = Maybe String + +-- TODO: we shouldn't use 'FilePath.' +withBaseURL :: BaseURL -> String -> String +withBaseURL Nothing uri = uri +withBaseURL (Just baseUrl) uri = baseUrl FilePath. uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs) -- cgit v1.2.3 From 0000202ce6e5a169877181efe8da0555fac109a3 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Sat, 27 Nov 2021 05:14:17 -0500 Subject: fix CI for 9.2 (#1436) --- .github/workflows/ci.yml | 4 ++-- cabal.project | 16 ++++++++-------- haddock-api/haddock-api.cabal | 4 ++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 1 - haddock-library/haddock-library.cabal | 4 ++-- 5 files changed, 14 insertions(+), 15 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 83677352..9268c6b7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,9 +13,9 @@ jobs: strategy: matrix: os: [ubuntu-latest] - cabal: ["3.4"] + cabal: ["3.6"] ghc: - - "9.2.0.20210821" + - "9.2.1" steps: - uses: actions/checkout@v2 diff --git a/cabal.project b/cabal.project index bac38a52..593a1eaf 100644 --- a/cabal.project +++ b/cabal.project @@ -44,7 +44,7 @@ constraints: alex ==3.2.6, ansi-pretty ==0.1.2.2, arith-encode ==1.0.2, - attoparsec ==0.13.2.5 || ==0.14.1, + attoparsec ==0.13.2.5 || ==0.14.2, barbies ==2.0.2.0, barbies-th ==0.1.8, base-compat ==0.11.2, @@ -64,7 +64,7 @@ constraints: cassava ==0.5.2.0, cborg ==0.2.5.0, cereal ==0.5.8.1, - charset ==0.3.8, + charset ==0.3.9, chaselev-deque ==0.5.0.5, colour ==2.3.5, combinat ==0.2.10.0, @@ -106,7 +106,7 @@ constraints: heterocephalus ==1.0.5.4, hgeometry ==0.11.0.0, hgeometry-ipe ==0.11.0.0, - hspec-discover ==2.8.2, + hspec-discover ==2.9.1, hspec-expectations ==0.8.2, hspec-meta ==2.7.8, hspec-wai ==0.11.1, @@ -141,19 +141,19 @@ constraints: plots ==0.1.1.2, pointed ==5.0.2, posix-api ==0.3.4.0, - primitive ==0.7.1.0, + primitive ==0.7.3.0, primitive-extras ==0.10.1, primitive-sort ==0.1.0.0, primitive-unlifted ==0.1.3.0, proto3-wire ==1.2.2, quickcheck-instances ==0.3.25.2, - random ==1.2.0, + random ==1.2.1, row-types ==1.0.1.0, safe ==0.3.19, safecopy ==0.10.4.2, salak ==0.3.6, - semialign ==1.2, - semigroupoids ==5.3.5, + semialign ==1.2.0.1, + semigroupoids ==5.3.6, serialise ==0.2.3.0, servant ==0.18.2, shake ==0.19.4, @@ -172,7 +172,7 @@ constraints: th-desugar ==1.11 || ==1.12, tls ==1.5.5, tpdb ==2.2.0, - tree-diff ==0.2, + tree-diff ==0.2.1, true-name ==0.1.0.3, uniplate ==1.6.13, vector-builder ==0.3.8.1, diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6258613e..01165582 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -184,7 +184,7 @@ test-suite spec , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 - , hspec ^>= 2.8 + , hspec ^>= 2.9 , parsec ^>= 3.1.13.0 , QuickCheck >= 2.11 && ^>= 2.14 @@ -205,7 +205,7 @@ test-suite spec , transformers build-tool-depends: - hspec-discover:hspec-discover ^>= 2.8 + hspec-discover:hspec-discover ^>= 2.9 source-repository head type: git diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index d16aa24e..5bbea77b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -107,4 +107,3 @@ highlightScript = "highlight.js" -- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 93e3fc82..688a48c1 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -95,10 +95,10 @@ test-suite spec -- version of `hspec` & `hspec-discover` to ensure -- intercompatibility build-depends: - , hspec >= 2.4.4 && < 2.9 + , hspec >= 2.4.4 && < 2.10 build-tool-depends: - , hspec-discover:hspec-discover >= 2.4.4 && < 2.9 + , hspec-discover:hspec-discover >= 2.4.4 && < 2.10 test-suite fixtures type: exitcode-stdio-1.0 -- cgit v1.2.3