aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Utils/Json
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Utils/Json')
-rw-r--r--haddock-api/src/Haddock/Utils/Json/Parser.hs102
-rw-r--r--haddock-api/src/Haddock/Utils/Json/Types.hs42
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