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.hs137
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Types.hs11
-rw-r--r--haddock-api/src/Haddock/Options.hs7
-rw-r--r--haddock-api/src/Haddock/Utils/Json.hs378
-rw-r--r--haddock-api/src/Haddock/Utils/Json/Parser.hs102
-rw-r--r--haddock-api/src/Haddock/Utils/Json/Types.hs42
7 files changed, 623 insertions, 61 deletions
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