aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs58
-rw-r--r--haddock-api/src/Haddock/Utils.hs5
-rw-r--r--haddock-api/src/Haddock/Utils/Json.hs225
3 files changed, 284 insertions, 4 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 249389b9..78bd0262 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
@@ -87,10 +88,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
@@ -340,6 +343,57 @@ 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 =
+ case processExport True links_info unicode qual item of
+ Nothing -> []
+ Just html ->
+ [ Object
+ [ "display_html" .= String (showHtmlFragment html)
+ , "name" .= String (intercalate " " (map nameString names))
+ , "module" .= String (moduleString mdl)
+ , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
+ ]
+ ]
+ where
+ names = exportName item
+
+ 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/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 7a9d65a4..200cd00a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -20,7 +20,7 @@ module Haddock.Utils (
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
- contentsHtmlFile, indexHtmlFile,
+ contentsHtmlFile, indexHtmlFile, indexJsonFile,
moduleIndexFrameName, mainFrameName, synopsisFrameName,
subIndexHtmlFile,
jsFile,
@@ -254,9 +254,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"
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 2024-11-11 11:01:44 +0000