diff options
Diffstat (limited to 'haddock-api/src')
| -rw-r--r-- | haddock-api/src/Haddock.hs | 81 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 137 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 11 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Options.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Utils/Json.hs | 378 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Utils/Json/Parser.hs | 102 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Utils/Json/Types.hs | 42 |
8 files changed, 681 insertions, 84 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 9158d83c..942798eb 100644 --- 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 Control.Monad.IO.Class (MonadIO(..)) 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 @@ -75,6 +79,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit +import GHC.Unit.State (lookupUnit) import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString @@ -193,7 +198,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do name_cache <- freshNameCache mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks - forM_ mIfaceFile $ \(_, ifaceFile) -> do + forM_ mIfaceFile $ \(_,_, ifaceFile) -> do putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do @@ -254,7 +259,7 @@ withGhc flags action = do 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 @@ -262,28 +267,42 @@ readPackagesAndProcessModules flags files = do packages <- liftIO $ readInterfaceFiles name_cache (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 :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption - -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () + -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs pkgs + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> + ( case baseUrl flags of + Nothing -> fst docPath + Just url -> url </> packageName (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 logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + where + -- get package name from unit-id + packageName :: Unit -> String + packageName unit = + case lookupUnit unit_state unit of + Nothing -> show unit + Just pkg -> unitPackageNameString pkg -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] - -> [InstalledInterface] -> Map Module FilePath -> IO () + -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO () render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let @@ -291,6 +310,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc 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 @@ -305,7 +325,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc 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) @@ -350,7 +370,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc 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 @@ -373,6 +393,13 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc 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 logger "ppHtmlIndex" (const ()) $ do @@ -382,7 +409,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc allVisibleIfaces pretty return () - copyHtmlBits odir libDir themes withQuickjump + unless withBaseURL $ + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do withTiming logger "ppHtmlContents" (const ()) $ do @@ -394,17 +422,24 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc 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 logger "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state 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 @@ -451,7 +486,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc readInterfaceFiles :: NameCache -> [(DocPaths, FilePath)] -> Bool - -> IO [(DocPaths, InterfaceFile)] + -> IO [(DocPaths, FilePath, InterfaceFile)] readInterfaceFiles name_cache pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where @@ -463,7 +498,7 @@ readInterfaceFiles name_cache pairs bypass_version_check = do putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return $ Just (paths, f) + Right f -> return (Just (paths, file, f)) ------------------------------------------------------------------------------- @@ -684,12 +719,12 @@ hypSrcWarnings flags = do 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 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) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 4d22505f..aa10b5b3 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -24,6 +24,7 @@ module Haddock.Options ( optSourceCssFile, sourceUrls, wikiUrls, + baseUrl, optParCount, optDumpInterfaceFile, optShowInterfaceFile, @@ -72,6 +73,7 @@ data Flag | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String + | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX @@ -157,6 +159,8 @@ options backwardsCompat = "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 @@ wikiUrls 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 index 2270a547..d5d5ae02 100644 --- 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 @@ module Haddock.Utils.Json , 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,13 +68,6 @@ infixr 8 .= (.=) :: 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 @@ -223,3 +236,324 @@ escapeString s -- 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 "<input>" 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 "<input>" 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 index 00000000..018e27d3 --- /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 index 00000000..1174329c --- /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 |