diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,7 @@ +## Changes in 2.25.1 + + * Better support for multiple packages (#1277) + ## Changes in 2.25.0 * Fix crash in `haddock-library` on unicode space (#1144) diff --git a/doc/invoking.rst b/doc/invoking.rst --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -223,6 +223,13 @@ Reserved for future use (output documentation in DocBook XML format). +.. option:: --base-url= + + Base url for static assets (eg. css, javascript, json files etc.). + When present, static assets are not copied. This option is useful + when creating documentation for multiple packages, it allows to have + a single copy of static assets served from the given url. + .. option:: --source-base= --source-module= --source-entity= diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -1,6 +1,10 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock @@ -46,7 +50,7 @@ import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) -import Data.List (isPrefixOf) +import Data.List (find, isPrefixOf, nub) import Control.Exception import Data.Maybe import Data.IORef @@ -74,6 +78,7 @@ import GHC.Unit import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString +import qualified Debug.Trace as Debug -------------------------------------------------------------------------------- -- * Exception handling @@ -187,7 +192,7 @@ forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks - forM_ mIfaceFile $ \(_, ifaceFile) -> do + forM_ mIfaceFile $ \(_, _, ifaceFile) -> do logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do @@ -247,35 +252,50 @@ readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map snd packages + let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption - -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () + -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep dflags flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs pkgs + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> + ( case baseUrl flags of + Nothing -> fst docPath + Just url -> Debug.traceShowId $ + url packageName (unitState dflags) (ifUnitId ifaceFile) + , ifaceFile)) pkgs) let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles + installedIfaces = + concatMap + (\(_, ifaceFilePath, ifaceFile) + -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile) + pkgs extSrcMap = Map.fromList $ do - ((_, Just path), ifile) <- pkgs + ((_, Just path), _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap + where + -- get package name from unit-id + packageName :: UnitState -> Unit -> String + packageName state unit = + case lookupUnit state unit of + Nothing -> show unit + Just pkg -> unitPackageNameString pkg -- | Render the interfaces with whatever backend is specified in the flags. render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] - -> [InstalledInterface] -> Map Module FilePath -> IO () + -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO () render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do let @@ -283,6 +303,7 @@ unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags + opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags @@ -297,7 +318,7 @@ visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ installedIfaces + allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces) @@ -342,7 +363,7 @@ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') installedMap :: Map Module InstalledInterface - installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] + installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it @@ -365,6 +386,13 @@ themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags + withBaseURL = isJust + . find (\flag -> case flag of + Flag_BaseURL base_url -> + base_url /= "." && base_url /= "./" + _ -> False + ) + $ flags when (Flag_GenIndex `elem` flags) $ do withTiming dflags' "ppHtmlIndex" (const ()) $ do @@ -374,7 +402,8 @@ allVisibleIfaces pretty return () - copyHtmlBits odir libDir themes withQuickjump + unless withBaseURL $ + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do @@ -386,17 +415,24 @@ return () copyHtmlBits odir libDir themes withQuickjump + when withQuickjump $ void $ + ppJsonIndex odir sourceUrls' opt_wiki_urls + unicode Nothing qual + ifaces + (nub $ map fst installedIfaces) + when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir prologue - themes opt_mathjax sourceUrls' opt_wiki_urls + themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return () - copyHtmlBits odir libDir themes withQuickjump - writeHaddockMeta odir withQuickjump + unless withBaseURL $ do + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- 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 @@ -444,7 +480,7 @@ => NameCacheAccessor m -> [(DocPaths, FilePath)] -> Bool - -> m [(DocPaths, InterfaceFile)] + -> m [(DocPaths, FilePath, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where @@ -456,7 +492,7 @@ putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return $ Just (paths, f) + Right f -> return (Just (paths, file, f)) ------------------------------------------------------------------------------- @@ -676,12 +712,12 @@ isSourceCssFlag _ = False -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () +updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) writeIORef html_xrefs_ref' (Map.fromList mapping') where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs --- 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 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 @@ -> 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 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 @@ 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 @@ 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 @@ | 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 @@ -- * 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 @@ -> 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) + encodeIndexes :: [JsonIndexEntry] -> Value + encodeIndexes installedIndexes = + toJSON + (concatMap fromInterface ifaces + ++ installedIndexes) - goInterface :: Interface -> [Value] - goInterface iface = - concatMap (goExport mdl qual) (ifaceRnExportItems iface) + 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 @@ 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 @@ 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 @@ 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 @@ = 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 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,6 +17,7 @@ where import Haddock.Options +import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) @@ -176,13 +177,13 @@ 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 --- 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 @@ 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) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -24,6 +24,7 @@ optSourceCssFile, sourceUrls, wikiUrls, + baseUrl, optParCount, optDumpInterfaceFile, optShowInterfaceFile, @@ -73,6 +74,7 @@ | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String + | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX @@ -158,6 +160,8 @@ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") "URL for a comments link on the contents\nand index pages", + Option [] ["base-url"] (ReqArg Flag_BaseURL "URL") + "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.", Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") "URL for a comments link for each module\n(using the %{MODULE} var)", Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") @@ -301,6 +305,9 @@ ,optLast [str | Flag_WikiModuleURL str <- flags] ,optLast [str | Flag_WikiEntityURL str <- flags]) + +baseUrl :: [Flag] -> Maybe String +baseUrl flags = optLast [str | Flag_BaseURL str <- flags] optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs --- a/haddock-api/src/Haddock/Utils/Json.hs +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -- | Minimal JSON / RFC 7159 support -- @@ -12,35 +14,53 @@ , encodeToString , encodeToBuilder , ToJSON(toJSON) + + , Parser(..) + , Result(..) + , FromJSON(parseJSON) + , withObject + , withArray + , withString + , withDouble + , withBool + , fromJSON + , parse + , parseEither + , (.:) + , (.:?) + , decode + , decodeWith + , eitherDecode + , eitherDecodeWith + , decodeFile + , eitherDecodeFile ) where +import Control.Applicative (Alternative (..)) +import Control.Monad (MonadPlus (..), zipWithM, (>=>)) +import qualified Control.Monad as Monad +import qualified Control.Monad.Fail as Fail + +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB import Data.Char import Data.Int -import Data.String import Data.Word import Data.List (intersperse) import Data.Monoid -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB +import GHC.Natural -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' --- | A JSON value represented as a Haskell value. -data Value = Object !Object - | Array [Value] - | String String - | Number !Double - | Bool !Bool - | Null - deriving (Eq, Read, Show) +import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy +import qualified Text.ParserCombinators.Parsec as Parsec --- | A key\/value pair for an 'Object' -type Pair = (String, Value) +import Haddock.Utils.Json.Types +import Haddock.Utils.Json.Parser --- | A JSON \"object\" (key/value map). -type Object = [Pair] infixr 8 .= @@ -48,14 +68,7 @@ (.=) :: ToJSON v => String -> v -> Pair k .= v = (k, toJSON v) --- | Create a 'Value' from a list of name\/value 'Pair's. -object :: [Pair] -> Value -object = Object -instance IsString Value where - fromString = String - - -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type. @@ -223,3 +236,324 @@ -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] + +------------------------------------------------------------------------------ +-- FromJSON + +-- | Elements of a JSON path used to describe the location of an +-- error. +data JSONPathElement + = Key String + -- ^ JSON path element of a key into an object, + -- \"object.key\". + | Index !Int + -- ^ JSON path element of an index into an + -- array, \"array[index]\". + deriving (Eq, Show, Ord) + +type JSONPath = [JSONPathElement] + +-- | Failure continuation. +type Failure f r = JSONPath -> String -> f r + +-- | Success continuation. +type Success a f r = a -> f r + +newtype Parser a = Parser { + runParser :: forall f r. + JSONPath + -> Failure f r + -> Success a f r + -> f r + } + +modifyFailure :: (String -> String) -> Parser a -> Parser a +modifyFailure f (Parser p) = Parser $ \path kf ks -> + p path (\p' m -> kf p' (f m)) ks + +prependFailure :: String -> Parser a -> Parser a +prependFailure = modifyFailure . (++) + +prependContext :: String -> Parser a -> Parser a +prependContext name = prependFailure ("parsing " ++ name ++ " failed, ") + +typeMismatch :: String -> Value -> Parser a +typeMismatch expected actual = + fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual + +instance Monad.Monad Parser where + m >>= g = Parser $ \path kf ks -> + runParser m path kf + (\a -> runParser (g a) path kf ks) + return = pure + +instance Fail.MonadFail Parser where + fail msg = Parser $ \path kf _ks -> kf (reverse path) msg + +instance Functor Parser where + fmap f m = Parser $ \path kf ks -> + let ks' a = ks (f a) + in runParser m path kf ks' + +instance Applicative Parser where + pure a = Parser $ \_path _kf ks -> ks a + (<*>) = apP + +instance Alternative Parser where + empty = fail "empty" + (<|>) = mplus + +instance MonadPlus Parser where + mzero = fail "mzero" + mplus a b = Parser $ \path kf ks -> + runParser a path (\_ _ -> runParser b path kf ks) ks + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + mappend = (<>) + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + b <$> e + +() :: Parser a -> JSONPathElement -> Parser a +p pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks + +parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a +parseIndexedJSON p idx value = p value Index idx + +unexpected :: Value -> Parser a +unexpected actual = fail $ "unexpected " ++ typeOf actual + +withObject :: String -> (Object -> Parser a) -> Value -> Parser a +withObject _ f (Object obj) = f obj +withObject name _ v = prependContext name (typeMismatch "Object" v) + +withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a +withArray _ f (Array arr) = f arr +withArray name _ v = prependContext name (typeMismatch "Array" v) + +withString :: String -> (String -> Parser a) -> Value -> Parser a +withString _ f (String txt) = f txt +withString name _ v = prependContext name (typeMismatch "String" v) + +withDouble :: String -> (Double -> Parser a) -> Value -> Parser a +withDouble _ f (Number duble) = f duble +withDouble name _ v = prependContext name (typeMismatch "Number" v) + +withBool :: String -> (Bool -> Parser a) -> Value -> Parser a +withBool _ f (Bool arr) = f arr +withBool name _ v = prependContext name (typeMismatch "Boolean" v) + +class FromJSON a where + parseJSON :: Value -> Parser a + + parseJSONList :: Value -> Parser [a] + parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..]) + +instance FromJSON Bool where + parseJSON (Bool b) = pure b + parseJSON v = typeMismatch "Bool" v + +instance FromJSON () where + parseJSON = + withArray "()" $ \v -> + if null v + then pure () + else prependContext "()" $ fail "expected an empty array" + +instance FromJSON Char where + parseJSON = withString "Char" parseChar + + parseJSONList (String s) = pure s + parseJSONList v = typeMismatch "String" v + +parseChar :: String -> Parser Char +parseChar t = + if length t == 1 + then pure $ head t + else prependContext "Char" $ fail "expected a string of length 1" + +parseRealFloat :: RealFloat a => String -> Value -> Parser a +parseRealFloat _ (Number s) = pure $ realToFrac s +parseRealFloat _ Null = pure (0/0) +parseRealFloat name v = prependContext name (unexpected v) + +instance FromJSON Double where + parseJSON = parseRealFloat "Double" + +instance FromJSON Float where + parseJSON = parseRealFloat "Float" + +parseNatural :: Integer -> Parser Natural +parseNatural integer = + if integer < 0 then + fail $ "parsing Natural failed, unexpected negative number " <> show integer + else + pure $ fromIntegral integer + +parseIntegralFromDouble :: Integral a => Double -> Parser a +parseIntegralFromDouble d = + let r = toRational d + x = truncate r + in if toRational x == r + then pure $ x + else fail $ "unexpected floating number " <> show d + +parseIntegral :: Integral a => String -> Value -> Parser a +parseIntegral name = withDouble name parseIntegralFromDouble + +instance FromJSON Integer where + parseJSON = parseIntegral "Integer" + +instance FromJSON Natural where + parseJSON = withDouble "Natural" + (parseIntegralFromDouble >=> parseNatural) + +instance FromJSON Int where + parseJSON = parseIntegral "Int" + +instance FromJSON Int8 where + parseJSON = parseIntegral "Int8" + +instance FromJSON Int16 where + parseJSON = parseIntegral "Int16" + +instance FromJSON Int32 where + parseJSON = parseIntegral "Int32" + +instance FromJSON Int64 where + parseJSON = parseIntegral "Int64" + +instance FromJSON Word where + parseJSON = parseIntegral "Word" + +instance FromJSON Word8 where + parseJSON = parseIntegral "Word8" + +instance FromJSON Word16 where + parseJSON = parseIntegral "Word16" + +instance FromJSON Word32 where + parseJSON = parseIntegral "Word32" + +instance FromJSON Word64 where + parseJSON = parseIntegral "Word64" + +instance FromJSON a => FromJSON [a] where + parseJSON = parseJSONList + +data Result a = Error String + | Success a + deriving (Eq, Show) + +fromJSON :: FromJSON a => Value -> Result a +fromJSON = parse parseJSON + +parse :: (a -> Parser b) -> a -> Result b +parse m v = runParser (m v) [] (const Error) Success + +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither m v = runParser (m v) [] onError Right + where onError path msg = Left (formatError path msg) + +formatError :: JSONPath -> String -> String +formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg + +formatPath :: JSONPath -> String +formatPath path = "$" ++ formatRelativePath path + +formatRelativePath :: JSONPath -> String +formatRelativePath path = format "" path + where + format :: String -> JSONPath -> String + format pfx [] = pfx + format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts + format pfx (Key key:parts) = format (pfx ++ formatKey key) parts + + formatKey :: String -> String + formatKey key + | isIdentifierKey key = "." ++ key + | otherwise = "['" ++ escapeKey key ++ "']" + + isIdentifierKey :: String -> Bool + isIdentifierKey [] = False + isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs + + escapeKey :: String -> String + escapeKey = concatMap escapeChar + + escapeChar :: Char -> String + escapeChar '\'' = "\\'" + escapeChar '\\' = "\\\\" + escapeChar c = [c] + +explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a +explicitParseField p obj key = + case key `lookup` obj of + Nothing -> fail $ "key " ++ key ++ " not found" + Just v -> p v Key key + +(.:) :: FromJSON a => Object -> String -> Parser a +(.:) = explicitParseField parseJSON + +explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a) +explicitParseFieldMaybe p obj key = + case key `lookup` obj of + Nothing -> pure Nothing + Just v -> Just <$> p v Key key + +(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a) +(.:?) = explicitParseFieldMaybe parseJSON + + +decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a +decodeWith decoder bsl = + case Parsec.parse parseJSONValue "" bsl of + Left _ -> Nothing + Right json -> + case decoder json of + Success a -> Just a + Error _ -> Nothing + +decode :: FromJSON a => BSL.ByteString -> Maybe a +decode = decodeWith fromJSON + +eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a +eitherDecodeWith decoder bsl = + case Parsec.parse parseJSONValue "" bsl of + Left parsecError -> Left (show parsecError) + Right json -> + case decoder json of + Success a -> Right a + Error err -> Left err + +eitherDecode :: FromJSON a => BSL.ByteString -> Either String a +eitherDecode = eitherDecodeWith fromJSON + + +decodeFile :: FromJSON a => FilePath -> IO (Maybe a) +decodeFile filePath = do + parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath + case parsecResult of + Right r -> + case fromJSON r of + Success a -> return (Just a) + Error _ -> return Nothing + Left _ -> return Nothing + + +eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a) +eitherDecodeFile filePath = do + parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath + case parsecResult of + Right r -> + case fromJSON r of + Success a -> return (Right a) + Error err -> return (Left err) + Left err -> return $ Left (show err) + diff --git a/haddock-api/src/Haddock/Utils/Json/Parser.hs b/haddock-api/src/Haddock/Utils/Json/Parser.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Utils/Json/Parser.hs @@ -0,0 +1,102 @@ +-- | Json "Parsec" parser, based on +-- [json](https://hackage.haskell.org/package/json) package. +-- +module Haddock.Utils.Json.Parser + ( parseJSONValue + ) where + +import Prelude hiding (null) + +import Control.Applicative (Alternative (..)) +import Control.Monad (MonadPlus (..)) +import Data.Char (isHexDigit) +import Data.Functor (($>)) +import qualified Data.ByteString.Lazy.Char8 as BSCL +import Numeric +import Text.Parsec.ByteString.Lazy (Parser) +import Text.ParserCombinators.Parsec (()) +import qualified Text.ParserCombinators.Parsec as Parsec + +import Haddock.Utils.Json.Types hiding (object) + +parseJSONValue :: Parser Value +parseJSONValue = Parsec.spaces *> parseValue + +tok :: Parser a -> Parser a +tok p = p <* Parsec.spaces + +parseValue :: Parser Value +parseValue = + parseNull + <|> Bool <$> parseBoolean + <|> Array <$> parseArray + <|> String <$> parseString + <|> Object <$> parseObject + <|> Number <$> parseNumber + "JSON value" + +parseNull :: Parser Value +parseNull = tok + $ Parsec.string "null" + $> Null + +parseBoolean :: Parser Bool +parseBoolean = tok + $ Parsec.string "true" $> True + <|> Parsec.string "false" $> False + +parseArray :: Parser [Value] +parseArray = + Parsec.between + (tok (Parsec.char '[')) + (tok (Parsec.char ']')) + (parseValue `Parsec.sepBy` tok (Parsec.char ',')) + +parseString :: Parser String +parseString = + Parsec.between + (tok (Parsec.char '"')) + (tok (Parsec.char '"')) + (many char) + where + char = (Parsec.char '\\' >> escapedChar) + <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\') + + escapedChar = + Parsec.char '"' $> '"' + <|> Parsec.char '\\' $> '\\' + <|> Parsec.char '/' $> '/' + <|> Parsec.char 'b' $> '\b' + <|> Parsec.char 'f' $> '\f' + <|> Parsec.char 'n' $> '\n' + <|> Parsec.char 'r' $> '\r' + <|> Parsec.char 't' $> '\t' + <|> Parsec.char 'u' *> uni + "escape character" + + uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit) + where + check x | code <= max_char = return (toEnum code) + | otherwise = mzero + where code = fst $ head $ readHex x + max_char = fromEnum (maxBound :: Char) + +parseObject :: Parser Object +parseObject = + Parsec.between + (tok (Parsec.char '{')) + (tok (Parsec.char '}')) + (field `Parsec.sepBy` tok (Parsec.char ',')) + where + field :: Parser (String, Value) + field = (,) + <$> parseString + <* tok (Parsec.char ':') + <*> parseValue + +parseNumber :: Parser Double +parseNumber = tok $ do + s <- BSCL.unpack <$> Parsec.getInput + case readSigned readFloat s of + [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n + _ -> mzero diff --git a/haddock-api/src/Haddock/Utils/Json/Types.hs b/haddock-api/src/Haddock/Utils/Json/Types.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Utils/Json/Types.hs @@ -0,0 +1,42 @@ +module Haddock.Utils.Json.Types + ( Value(..) + , typeOf + , Pair + , Object + , object + ) where + +import Data.String + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +typeOf :: Value -> String +typeOf v = case v of + Object _ -> "Object" + Array _ -> "Array" + String _ -> "String" + Number _ -> "Number" + Bool _ -> "Boolean" + Null -> "Null" + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: haddock -version: 2.25.0 +version: 2.25.1 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -27,7 +27,7 @@ license: BSD-3-Clause license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk +maintainer: Hécate Moonlight , Alex Biehl homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern @@ -111,6 +111,8 @@ Haddock.Parser Haddock.Utils Haddock.Utils.Json + Haddock.Utils.Json.Parser + Haddock.Utils.Json.Types Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup @@ -146,7 +148,7 @@ else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.25.0 + build-depends: haddock-api == 2.25.1 test-suite html-test type: exitcode-stdio-1.0 diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html --- a/html-test/ref/Bug1004.html +++ b/html-test/ref/Bug1004.html @@ -122,12 +122,8 @@ >Type)

Since: base-4.9.0.0

  ( (Typeable a, a, Typeable f, f, Typeable g, g, Typeable k, Data

dataCast1 :: :: Typeable t => (forall

dataCast2 :: :: Typeable t => (forallProduct f g a)

Since: base-4.9.0.0

 Type) 

Since: base-4.9.0.0

Product f g a) 

Since: base-4.9.0.0

  • type family (a :: (a :: Nat) + (b :: (b :: Nat) :: ) :: Nat where ...

    type family (a :: (a :: Nat) + (b :: (b :: Nat) :: ) :: Nat where ...Type)

    Since: base-4.7.0.0

     WrappedArrow a b c)

    Since: base-4.7.0.0

     Type) 

    Since: base-4.7.0.0

    WrappedArrow a b c) 

    Since: base-4.7.0.0

    data Vec :: :: Nat -> * -> * wheredata RTree :: :: Nat -> * -> * wheredata Vec :: :: Nat -> * -> * where subscript starting from 0 and ending at length - 1data RTree :: :: Nat -> * -> * wheredata Vec :: :: Nat -> * -> * wheredata RTree :: :: Nat -> * -> * wheredata Vec :: :: Nat -> * -> * where subscript starting from 0 and ending at length - 1data RTree :: :: Nat -> * -> * where++, elem
    • , ++, elem,
  • Unqualified: 1 `elem` [-3..3]
  • Qualified: 1 `elem` [-3..3]
  • Namespaced: `elem`,