diff options
author | Marcin Szamotulski <profunctor@pm.me> | 2021-08-16 08:46:03 +0200 |
---|---|---|
committer | GitHub <noreply@github.com> | 2021-08-16 08:46:03 +0200 |
commit | 1b63771dee5a7fac0696505d0b335908bd12835d (patch) | |
tree | 6f50d00fdb9813d5c49c405cf3651e01f9932cdc /haddock-api/src/Haddock/Utils/Json | |
parent | 32d280f30d73bb38769700be6ddaf26b9a69c77e (diff) |
coot/multiple package (ghc-head) (#1419)
* FromJSON class
Aeson style FromJSON class with Parsec based json parser.
* doc-index.json file for multiple packages
When creating haddock summary page for multiple packages render
doc-index.json file using contents of all found 'doc-index.json' files.
* Render doc-index.json
When rendering html, render doc-index.json file independently of
maybe_index_url option. doc-index.json file is useful now even if
maybe_index_url is not `Nothing`.
* base url option
New `Flag_BaseURL` which configures from where static files are loaded
(--base-url). If given and not equal "." static files are not coppied,
as this indicates that they are not read from the the directory where
we'd copy them. The default value is ".".
Diffstat (limited to 'haddock-api/src/Haddock/Utils/Json')
-rw-r--r-- | haddock-api/src/Haddock/Utils/Json/Parser.hs | 102 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Utils/Json/Types.hs | 42 |
2 files changed, 144 insertions, 0 deletions
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 |