aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Meta.hs22
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs76
-rw-r--r--haddock-api/src/Haddock/Interface.hs13
-rw-r--r--haddock-api/src/Haddock/Utils.hs17
-rw-r--r--haddock-api/src/Haddock/Utils/Json.hs225
6 files changed, 333 insertions, 22 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 44dfb7b2..de40d06d 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -29,6 +29,7 @@ import Data.Version
import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Themes (getThemes)
import Haddock.Backends.LaTeX
+import Haddock.Backends.Meta
import Haddock.Backends.Hoogle
import Haddock.Backends.Hyperlinker
import Haddock.Interface
@@ -318,6 +319,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
opt_contents_url opt_index_url unicode qual
pretty
copyHtmlBits odir libDir themes
+ writeHaddockMeta odir
-- 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
diff --git a/haddock-api/src/Haddock/Backends/Meta.hs b/haddock-api/src/Haddock/Backends/Meta.hs
new file mode 100644
index 00000000..c62c1ae8
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Meta.hs
@@ -0,0 +1,22 @@
+module Haddock.Backends.Meta where
+
+import Haddock.Utils.Json
+import Haddock.Version
+
+import Data.ByteString.Builder (hPutBuilder)
+import System.FilePath ((</>))
+import System.IO (withFile, IOMode (WriteMode))
+
+-- | Writes a json encoded file containing additional
+-- information about the generated documentation. This
+-- is useful for external tools (e.g. hackage).
+writeHaddockMeta :: FilePath -> IO ()
+writeHaddockMeta odir = do
+ let
+ meta_json :: Value
+ meta_json = object [
+ "haddock_version" .= String projectVersion
+ ]
+
+ withFile (odir </> "meta.json") WriteMode $ \h ->
+ hPutBuilder h (encodeToBuilder meta_json) \ No newline at end of file
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 7fbf9bb4..1205e57c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -11,7 +11,7 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, NamedFieldPuns #-}
module Haddock.Backends.Xhtml (
ppHtml, copyHtmlBits,
ppHtmlIndex, ppHtmlContents,
@@ -31,6 +31,7 @@ import Haddock.ModuleTree
import Haddock.Types
import Haddock.Version
import Haddock.Utils
+import Haddock.Utils.Json
import Text.XHtml hiding ( name, title, p, quote )
import Haddock.GhcUtils
@@ -88,10 +89,12 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue
False -- we don't want to display the packages in a single-package contents
prologue debug (makeContentsQual qual)
- when (isNothing maybe_index_url) $
+ when (isNothing maybe_index_url) $ do
ppHtmlIndex odir doctitle maybe_package
themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces) debug
+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
+ visible_ifaces
mapM_ (ppHtmlModule odir doctitle themes
maybe_mathjax_url maybe_source_url maybe_wiki_url
@@ -105,7 +108,9 @@ copyHtmlBits odir libdir themes = do
copyCssFile f = copyFile f (combine odir (takeFileName f))
copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
mapM_ copyCssFile (cssFiles themes)
- copyLibFile jsFile
+ copyCssFile (joinPath [libhtmldir, quickJumpCssFile])
+ copyLibFile haddockJsFile
+ copyLibFile jsQuickJumpFile
return ()
@@ -115,13 +120,9 @@ headHtml docTitle themes mathjax_url =
meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
thetitle << docTitle,
styleSheet themes,
- script ! [src jsFile, thetype "text/javascript"] << noHtml,
- script ! [src mjUrl, thetype "text/javascript"] << noHtml,
- script ! [thetype "text/javascript"]
- -- NB: Within XHTML, the content of script tags needs to be
- -- a <![CDATA[ section.
- << primHtml
- "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n"
+ thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml,
+ script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml,
+ script ! [src mjUrl, thetype "text/javascript"] << noHtml
]
where
mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
@@ -188,7 +189,6 @@ bodyHtml doctitle iface
)
]
-
moduleInfo :: Interface -> Html
moduleInfo iface =
let
@@ -341,6 +341,60 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
-- * Generate the index
--------------------------------------------------------------------------------
+ppJsonIndex :: FilePath
+ -> SourceURLs -- ^ The source URL (--source)
+ -> WikiURLs -- ^ The wiki URL (--wiki)
+ -> Bool
+ -> QualOption
+ -> [Interface]
+ -> IO ()
+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do
+ createDirectoryIfMissing True odir
+ writeFile (joinPath [odir, indexJsonFile])
+ (encodeToString modules)
+
+ where
+ modules :: Value
+ modules = Array (concatMap goInterface ifaces)
+
+ goInterface :: Interface -> [Value]
+ goInterface iface =
+ concatMap (goExport mdl qual) (ifaceRnExportItems iface)
+ where
+ aliases = ifaceModuleAliases iface
+ qual = makeModuleQual qual_opt aliases mdl
+ mdl = ifaceMod iface
+
+ goExport :: Module -> Qualification -> ExportItem DocName -> [Value]
+ goExport mdl qual item
+ | Just item_html <- processExport True links_info unicode qual item
+ = [ Object
+ [ "display_html" .= String (showHtmlFragment item_html)
+ , "name" .= String (intercalate " " (map nameString names))
+ , "module" .= String (moduleString mdl)
+ , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
+ ]
+ ]
+ | otherwise = []
+ where
+ names = exportName item ++ exportSubs item
+
+ exportSubs :: ExportItem DocName -> [DocName]
+ exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
+ exportSubs _ = []
+
+ exportName :: ExportItem DocName -> [DocName]
+ exportName ExportDecl { expItemDecl } = getMainDeclBinder $ unLoc expItemDecl
+ exportName ExportNoDecl { expItemName } = [expItemName]
+ exportName _ = []
+
+ nameString :: NamedThing name => name -> String
+ nameString = occNameString . nameOccName . getName
+
+ nameLink :: NamedThing name => Module -> name -> String
+ nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName
+
+ links_info = (maybe_source_url, maybe_wiki_url)
ppHtmlIndex :: FilePath
-> String
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 4c7b70d7..20689a8f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -191,12 +191,13 @@ processModule verbosity modsum flags modMap instIfaceMap = do
then drop (length ms) n
else n
- out verbosity normal coverageMsg
- when (Flag_NoPrintMissingDocs `notElem` flags
- && not (null undocumentedExports && header)) $ do
- out verbosity normal " Missing documentation for:"
- unless header $ out verbosity normal " Module header"
- mapM_ (out verbosity normal . (" " ++)) undocumentedExports
+ when (OptHide `notElem` ifaceOptions interface) $ do
+ out verbosity normal coverageMsg
+ when (Flag_NoPrintMissingDocs `notElem` flags
+ && not (null undocumentedExports && header)) $ do
+ out verbosity normal " Missing documentation for:"
+ unless header $ out verbosity normal " Module header"
+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports
interface' <- liftIO $ evaluate interface
return (Just interface')
else
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 540774dc..84f58ab8 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -20,10 +20,11 @@ module Haddock.Utils (
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
- contentsHtmlFile, indexHtmlFile,
+ contentsHtmlFile, indexHtmlFile, indexJsonFile,
moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
- jsFile,
+ haddockJsFile, jsQuickJumpFile,
+ quickJumpCssFile,
-- * Anchor and URL utilities
moduleNameUrl, moduleNameUrl', moduleUrl,
@@ -254,9 +255,10 @@ moduleHtmlFile' mdl =
Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]
-contentsHtmlFile, indexHtmlFile :: String
+contentsHtmlFile, indexHtmlFile, indexJsonFile :: String
contentsHtmlFile = "index.html"
indexHtmlFile = "doc-index.html"
+indexJsonFile = "doc-index.json"
@@ -324,9 +326,14 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
-------------------------------------------------------------------------------
-jsFile :: String
-jsFile = "haddock-util.js"
+haddockJsFile :: String
+haddockJsFile = "haddock-bundle.min.js"
+jsQuickJumpFile :: String
+jsQuickJumpFile = "quick-jump.min.js"
+
+quickJumpCssFile :: String
+quickJumpCssFile = "quick-jump.css"
-------------------------------------------------------------------------------
-- * Misc.
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
new file mode 100644
index 00000000..e3c3dddc
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Minimal JSON / RFC 7159 support
+--
+-- The API is heavily inspired by @aeson@'s API but puts emphasis on
+-- simplicity rather than performance. The 'ToJSON' instances are
+-- intended to have an encoding compatible with @aeson@'s encoding.
+--
+module Haddock.Utils.Json
+ ( Value(..)
+ , Object, object, Pair, (.=)
+ , encodeToString
+ , encodeToBuilder
+ , ToJSON(toJSON)
+ )
+ where
+
+import Data.Char
+import Data.Int
+import Data.String
+import Data.Word
+import Data.List
+import Data.Monoid
+
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
+
+-- 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)
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+infixr 8 .=
+
+-- | A key-value pair for encoding a JSON object.
+(.=) :: 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.
+ toJSON :: a -> Value
+
+instance ToJSON () where
+ toJSON () = Array []
+
+instance ToJSON Value where
+ toJSON = id
+
+instance ToJSON Bool where
+ toJSON = Bool
+
+instance ToJSON a => ToJSON [a] where
+ toJSON = Array . map toJSON
+
+instance ToJSON a => ToJSON (Maybe a) where
+ toJSON Nothing = Null
+ toJSON (Just a) = toJSON a
+
+instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
+ toJSON (a,b) = Array [toJSON a, toJSON b]
+
+instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
+ toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
+
+instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+ toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+
+instance ToJSON Float where
+ toJSON = Number . realToFrac
+
+instance ToJSON Double where
+ toJSON = Number
+
+instance ToJSON Int where toJSON = Number . realToFrac
+instance ToJSON Int8 where toJSON = Number . realToFrac
+instance ToJSON Int16 where toJSON = Number . realToFrac
+instance ToJSON Int32 where toJSON = Number . realToFrac
+
+instance ToJSON Word where toJSON = Number . realToFrac
+instance ToJSON Word8 where toJSON = Number . realToFrac
+instance ToJSON Word16 where toJSON = Number . realToFrac
+instance ToJSON Word32 where toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Int64 where toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Word64 where toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Integer where toJSON = Number . fromInteger
+
+------------------------------------------------------------------------------
+-- 'BB.Builder'-based encoding
+
+-- | Serialise value as JSON/UTF8-encoded 'Builder'
+encodeToBuilder :: ToJSON a => a -> Builder
+encodeToBuilder = encodeValueBB . toJSON
+
+encodeValueBB :: Value -> Builder
+encodeValueBB jv = case jv of
+ Bool True -> "true"
+ Bool False -> "false"
+ Null -> "null"
+ Number n
+ | isNaN n || isInfinite n -> encodeValueBB Null
+ | Just i <- doubleToInt64 n -> BB.int64Dec i
+ | otherwise -> BB.doubleDec n
+ Array a -> encodeArrayBB a
+ String s -> encodeStringBB s
+ Object o -> encodeObjectBB o
+
+encodeArrayBB :: [Value] -> Builder
+encodeArrayBB [] = "[]"
+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
+ where
+ go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB
+
+encodeObjectBB :: Object -> Builder
+encodeObjectBB [] = "{}"
+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
+ where
+ go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair
+ encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
+
+encodeStringBB :: String -> Builder
+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
+ where
+ go = BB.stringUtf8 . escapeString
+
+------------------------------------------------------------------------------
+-- 'String'-based encoding
+
+-- | Serialise value as JSON-encoded Unicode 'String'
+encodeToString :: ToJSON a => a -> String
+encodeToString jv = encodeValue (toJSON jv) []
+
+encodeValue :: Value -> ShowS
+encodeValue jv = case jv of
+ Bool b -> showString (if b then "true" else "false")
+ Null -> showString "null"
+ Number n
+ | isNaN n || isInfinite n -> encodeValue Null
+ | Just i <- doubleToInt64 n -> shows i
+ | otherwise -> shows n
+ Array a -> encodeArray a
+ String s -> encodeString s
+ Object o -> encodeObject o
+
+encodeArray :: [Value] -> ShowS
+encodeArray [] = showString "[]"
+encodeArray jvs = ('[':) . go jvs . (']':)
+ where
+ go [] = id
+ go [x] = encodeValue x
+ go (x:xs) = encodeValue x . (',':) . go xs
+
+encodeObject :: Object -> ShowS
+encodeObject [] = showString "{}"
+encodeObject jvs = ('{':) . go jvs . ('}':)
+ where
+ go [] = id
+ go [(l,x)] = encodeString l . (':':) . encodeValue x
+ go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs
+
+encodeString :: String -> ShowS
+encodeString str = ('"':) . showString (escapeString str) . ('"':)
+
+------------------------------------------------------------------------------
+-- helpers
+
+-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
+-- representable loss-free as integral 'Int64' value.
+doubleToInt64 :: Double -> Maybe Int64
+doubleToInt64 x
+ | fromInteger x' == x
+ , x' <= toInteger (maxBound :: Int64)
+ , x' >= toInteger (minBound :: Int64)
+ = Just (fromIntegral x')
+ | otherwise = Nothing
+ where
+ x' = round x
+
+-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
+escapeString :: String -> String
+escapeString s
+ | not (any needsEscape s) = s
+ | otherwise = escape s
+ where
+ escape [] = []
+ escape (x:xs) = case x of
+ '\\' -> '\\':'\\':escape xs
+ '"' -> '\\':'"':escape xs
+ '\b' -> '\\':'b':escape xs
+ '\f' -> '\\':'f':escape xs
+ '\n' -> '\\':'n':escape xs
+ '\r' -> '\\':'r':escape xs
+ '\t' -> '\\':'t':escape xs
+ c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
+ | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
+ | otherwise -> c : escape xs
+
+ -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
+ needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 14:10:38 +0000