{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
-- | Serialising Haskell values to and from JSON values.
module Text.JSON (
    -- * JSON Types
    JSValue(..)

    -- * Serialization to and from JSValues
  , JSON(..)

    -- * Encoding and Decoding
  , Result(..)
  , encode -- :: JSON a => a -> String
  , decode -- :: JSON a => String -> Either String a
  , encodeStrict -- :: JSON a => a -> String
  , decodeStrict -- :: JSON a => String -> Either String a

    -- * Wrapper Types
  , JSString
  , toJSString
  , fromJSString

  , JSObject
  , toJSObject
  , fromJSObject
  , resultToEither

    -- * Serialization to and from Strings.
    -- ** Reading JSON
  , readJSNull, readJSBool, readJSString, readJSRational
  , readJSArray, readJSObject, readJSValue

    -- ** Writing JSON
  , showJSNull, showJSBool, showJSArray
  , showJSRational, showJSRational'
  , showJSObject, showJSValue

    -- ** Instance helpers
  , makeObj, valFromObj
  , JSKey(..), encJSDict, decJSDict
  
  ) where

import Text.JSON.Types
import Text.JSON.String

import Data.Int
import Data.Word
import qualified Control.Monad.Fail as Fail
import Control.Monad(liftM,ap,MonadPlus(..))
import Control.Applicative

import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.IntSet as I
import qualified Data.Set as Set
import qualified Data.Map as M
import qualified Data.IntMap as IntMap

import qualified Data.Array as Array
import qualified Data.Text as T

------------------------------------------------------------------------

-- | Decode a String representing a JSON value 
-- (either an object, array, bool, number, null)
--
-- This is a superset of JSON, as types other than
-- Array and Object are allowed at the top level.
--
decode :: (JSON a) => String -> Result a
decode :: String -> Result a
decode s :: String
s = case GetJSON JSValue -> String -> Either String JSValue
forall a. GetJSON a -> String -> Either String a
runGetJSON GetJSON JSValue
readJSValue String
s of
             Right a :: JSValue
a  -> JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
             Left err :: String
err -> String -> Result a
forall a. String -> Result a
Error String
err

-- | Encode a Haskell value into a string, in JSON format.
--
-- This is a superset of JSON, as types other than
-- Array and Object are allowed at the top level.
--
encode :: (JSON a) => a -> String
encode :: a -> String
encode = ((JSValue -> String -> String) -> String -> JSValue -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip JSValue -> String -> String
showJSValue [] (JSValue -> String) -> (a -> JSValue) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JSValue
forall a. JSON a => a -> JSValue
showJSON)

------------------------------------------------------------------------

-- | Decode a String representing a strict JSON value.
-- This follows the spec, and requires top level
-- JSON types to be an Array or Object.
decodeStrict :: (JSON a) => String -> Result a
decodeStrict :: String -> Result a
decodeStrict s :: String
s = case GetJSON JSValue -> String -> Either String JSValue
forall a. GetJSON a -> String -> Either String a
runGetJSON GetJSON JSValue
readJSTopType String
s of
     Right a :: JSValue
a  -> JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
     Left err :: String
err -> String -> Result a
forall a. String -> Result a
Error String
err

-- | Encode a value as a String in strict JSON format.
-- This follows the spec, and requires all values
-- at the top level to be wrapped in either an Array or Object.
-- JSON types to be an Array or Object.
encodeStrict :: (JSON a) => a -> String
encodeStrict :: a -> String
encodeStrict = ((JSValue -> String -> String) -> String -> JSValue -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip JSValue -> String -> String
showJSTopType [] (JSValue -> String) -> (a -> JSValue) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> JSValue
forall a. JSON a => a -> JSValue
showJSON)

------------------------------------------------------------------------

-- | The class of types serialisable to and from JSON
class JSON a where
  readJSON  :: JSValue -> Result a
  showJSON  :: a -> JSValue

  readJSONs :: JSValue -> Result [a]
  readJSONs (JSArray as :: [JSValue]
as) = (JSValue -> Result a) -> [JSValue] -> Result [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON [JSValue]
as
  readJSONs _            = String -> Result [a]
forall a. String -> Result a
mkError "Unable to read list"

  showJSONs :: [a] -> JSValue
  showJSONs = [JSValue] -> JSValue
JSArray ([JSValue] -> JSValue) -> ([a] -> [JSValue]) -> [a] -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> JSValue) -> [a] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> JSValue
forall a. JSON a => a -> JSValue
showJSON

-- | A type for parser results
data Result a = Ok a | Error String
  deriving (Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq,Int -> Result a -> String -> String
[Result a] -> String -> String
Result a -> String
(Int -> Result a -> String -> String)
-> (Result a -> String)
-> ([Result a] -> String -> String)
-> Show (Result a)
forall a. Show a => Int -> Result a -> String -> String
forall a. Show a => [Result a] -> String -> String
forall a. Show a => Result a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result a] -> String -> String
$cshowList :: forall a. Show a => [Result a] -> String -> String
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Result a -> String -> String
Show)

-- | Map Results to Eithers
resultToEither :: Result a -> Either String a
resultToEither :: Result a -> Either String a
resultToEither (Ok a :: a
a)    = a -> Either String a
forall a b. b -> Either a b
Right a
a
resultToEither (Error s :: String
s) = String -> Either String a
forall a b. a -> Either a b
Left  String
s

instance Functor Result where fmap :: (a -> b) -> Result a -> Result b
fmap = (a -> b) -> Result a -> Result b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative Result where
  <*> :: Result (a -> b) -> Result a -> Result b
(<*>) = Result (a -> b) -> Result a -> Result b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  pure :: a -> Result a
pure  = a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Alternative Result where
  Ok a :: a
a    <|> :: Result a -> Result a -> Result a
<|> _ = a -> Result a
forall a. a -> Result a
Ok a
a
  Error _ <|> b :: Result a
b = Result a
b
  empty :: Result a
empty         = String -> Result a
forall a. String -> Result a
Error "empty"

instance MonadPlus Result where
  Ok a :: a
a mplus :: Result a -> Result a -> Result a
`mplus` _ = a -> Result a
forall a. a -> Result a
Ok a
a
  _ `mplus` x :: Result a
x    = Result a
x
  mzero :: Result a
mzero          = String -> Result a
forall a. String -> Result a
Error "Result: MonadPlus.empty"

instance Monad Result where
  return :: a -> Result a
return x :: a
x      = a -> Result a
forall a. a -> Result a
Ok a
x
  Ok a :: a
a >>= :: Result a -> (a -> Result b) -> Result b
>>= f :: a -> Result b
f    = a -> Result b
f a
a
  Error x :: String
x >>= _ = String -> Result b
forall a. String -> Result a
Error String
x

instance Fail.MonadFail Result where
  fail :: String -> Result a
fail x :: String
x        = String -> Result a
forall a. String -> Result a
Error String
x

-- | Convenient error generation
mkError :: String -> Result a
mkError :: String -> Result a
mkError s :: String
s = String -> Result a
forall a. String -> Result a
Error String
s

--------------------------------------------------------------------
--
-- | To ensure we generate valid JSON, we map Haskell types to JSValue
-- internally, then pretty print that.
--
instance JSON JSValue where
    showJSON :: JSValue -> JSValue
showJSON = JSValue -> JSValue
forall a. a -> a
id
    readJSON :: JSValue -> Result JSValue
readJSON = JSValue -> Result JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return

second :: (a -> b) -> (x,a) -> (x,b)
second :: (a -> b) -> (x, a) -> (x, b)
second f :: a -> b
f (a :: x
a,b :: a
b) = (x
a, a -> b
f a
b)

--------------------------------------------------------------------
-- Some simple JSON wrapper types, to avoid overlapping instances

instance JSON JSString where
  readJSON :: JSValue -> Result JSString
readJSON (JSString s :: JSString
s) = JSString -> Result JSString
forall (m :: * -> *) a. Monad m => a -> m a
return JSString
s
  readJSON _            = String -> Result JSString
forall a. String -> Result a
mkError "Unable to read JSString"
  showJSON :: JSString -> JSValue
showJSON = JSString -> JSValue
JSString

instance (JSON a) => JSON (JSObject a) where
  readJSON :: JSValue -> Result (JSObject a)
readJSON (JSObject o :: JSObject JSValue
o) =
      let f :: (a, JSValue) -> Result (a, b)
f (x :: a
x,y :: JSValue
y) = do b
y' <- JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
y; (a, b) -> Result (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x,b
y')
      in [(String, a)] -> JSObject a
forall a. [(String, a)] -> JSObject a
toJSObject ([(String, a)] -> JSObject a)
-> Result [(String, a)] -> Result (JSObject a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((String, JSValue) -> Result (String, a))
-> [(String, JSValue)] -> Result [(String, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, JSValue) -> Result (String, a)
forall b a. JSON b => (a, JSValue) -> Result (a, b)
f (JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o)
  readJSON _ = String -> Result (JSObject a)
forall a. String -> Result a
mkError "Unable to read JSObject"
  showJSON :: JSObject a -> JSValue
showJSON = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue)
-> (JSObject a -> JSObject JSValue) -> JSObject a -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject ([(String, JSValue)] -> JSObject JSValue)
-> (JSObject a -> [(String, JSValue)])
-> JSObject a
-> JSObject JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, a) -> (String, JSValue))
-> [(String, a)] -> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> JSValue) -> (String, a) -> (String, JSValue)
forall a b x. (a -> b) -> (x, a) -> (x, b)
second a -> JSValue
forall a. JSON a => a -> JSValue
showJSON) ([(String, a)] -> [(String, JSValue)])
-> (JSObject a -> [(String, a)])
-> JSObject a
-> [(String, JSValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSObject a -> [(String, a)]
forall e. JSObject e -> [(String, e)]
fromJSObject


-- -----------------------------------------------------------------
-- Instances
--

instance JSON Bool where
  showJSON :: Bool -> JSValue
showJSON = Bool -> JSValue
JSBool
  readJSON :: JSValue -> Result Bool
readJSON (JSBool b :: Bool
b) = Bool -> Result Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
  readJSON _          = String -> Result Bool
forall a. String -> Result a
mkError "Unable to read Bool"

instance JSON Char where
  showJSON :: Char -> JSValue
showJSON  = JSString -> JSValue
JSString (JSString -> JSValue) -> (Char -> JSString) -> Char -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString (String -> JSString) -> (Char -> String) -> Char -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:[])
  showJSONs :: String -> JSValue
showJSONs = JSString -> JSValue
JSString (JSString -> JSValue) -> (String -> JSString) -> String -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString

  readJSON :: JSValue -> Result Char
readJSON (JSString s :: JSString
s) = case JSString -> String
fromJSString JSString
s of
                            [c :: Char
c] -> Char -> Result Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
                            _ -> String -> Result Char
forall a. String -> Result a
mkError "Unable to read Char"
  readJSON _            = String -> Result Char
forall a. String -> Result a
mkError "Unable to read Char"

  readJSONs :: JSValue -> Result String
readJSONs (JSString s :: JSString
s)  = String -> Result String
forall (m :: * -> *) a. Monad m => a -> m a
return (JSString -> String
fromJSString JSString
s)
  readJSONs (JSArray a :: [JSValue]
a)   = (JSValue -> Result Char) -> [JSValue] -> Result String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JSValue -> Result Char
forall a. JSON a => JSValue -> Result a
readJSON [JSValue]
a
  readJSONs _             = String -> Result String
forall a. String -> Result a
mkError "Unable to read String"

instance JSON Ordering where
  showJSON :: Ordering -> JSValue
showJSON = (Ordering -> String) -> Ordering -> JSValue
forall a. (a -> String) -> a -> JSValue
encJSString Ordering -> String
forall a. Show a => a -> String
show
  readJSON :: JSValue -> Result Ordering
readJSON = String -> (String -> Result Ordering) -> JSValue -> Result Ordering
forall a. String -> (String -> Result a) -> JSValue -> Result a
decJSString "Ordering" String -> Result Ordering
readOrd
    where
     readOrd :: String -> Result Ordering
readOrd x :: String
x = 
       case String
x of
         "LT" -> Ordering -> Result Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
Prelude.LT
         "EQ" -> Ordering -> Result Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
Prelude.EQ
         "GT" -> Ordering -> Result Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
Prelude.GT
         _    -> String -> Result Ordering
forall a. String -> Result a
mkError ("Unable to read Ordering")

-- -----------------------------------------------------------------
-- Integral types

instance JSON Integer where
  showJSON :: Integer -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue)
-> (Integer -> Rational) -> Integer -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Integer
readJSON (JSRational _ i :: Rational
i) = Integer -> Result Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Result Integer) -> Integer -> Result Integer
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
i
  readJSON _             = String -> Result Integer
forall a. String -> Result a
mkError "Unable to read Integer"

-- constrained:
instance JSON Int where
  showJSON :: Int -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Int -> Rational) -> Int -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Int
readJSON (JSRational _ i :: Rational
i) = Int -> Result Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Result Int) -> Int -> Result Int
forall a b. (a -> b) -> a -> b
$ Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
i
  readJSON _              = String -> Result Int
forall a. String -> Result a
mkError "Unable to read Int"

-- constrained:
instance JSON Word where
  showJSON :: Word -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Word -> Rational) -> Word -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Rational
forall a. Real a => a -> Rational
toRational
  readJSON :: JSValue -> Result Word
readJSON (JSRational _ i :: Rational
i) = Word -> Result Word
forall (m :: * -> *) a. Monad m => a -> m a
return (Word -> Result Word) -> Word -> Result Word
forall a b. (a -> b) -> a -> b
$ Rational -> Word
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Word
forall a. String -> Result a
mkError "Unable to read Word"

-- -----------------------------------------------------------------

instance JSON Word8 where
  showJSON :: Word8 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Word8 -> Rational) -> Word8 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Word8
readJSON (JSRational _ i :: Rational
i) = Word8 -> Result Word8
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Result Word8) -> Word8 -> Result Word8
forall a b. (a -> b) -> a -> b
$ Rational -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Word8
forall a. String -> Result a
mkError "Unable to read Word8"

instance JSON Word16 where
  showJSON :: Word16 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Word16 -> Rational) -> Word16 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Word16
readJSON (JSRational _ i :: Rational
i) = Word16 -> Result Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Result Word16) -> Word16 -> Result Word16
forall a b. (a -> b) -> a -> b
$ Rational -> Word16
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Word16
forall a. String -> Result a
mkError "Unable to read Word16"

instance JSON Word32 where
  showJSON :: Word32 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Word32 -> Rational) -> Word32 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Word32
readJSON (JSRational _ i :: Rational
i) = Word32 -> Result Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Result Word32) -> Word32 -> Result Word32
forall a b. (a -> b) -> a -> b
$ Rational -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Word32
forall a. String -> Result a
mkError "Unable to read Word32"

instance JSON Word64 where
  showJSON :: Word64 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Word64 -> Rational) -> Word64 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Word64
readJSON (JSRational _ i :: Rational
i) = Word64 -> Result Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Result Word64) -> Word64 -> Result Word64
forall a b. (a -> b) -> a -> b
$ Rational -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Word64
forall a. String -> Result a
mkError "Unable to read Word64"

instance JSON Int8 where
  showJSON :: Int8 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Int8 -> Rational) -> Int8 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Int8
readJSON (JSRational _ i :: Rational
i) = Int8 -> Result Int8
forall (m :: * -> *) a. Monad m => a -> m a
return (Int8 -> Result Int8) -> Int8 -> Result Int8
forall a b. (a -> b) -> a -> b
$ Rational -> Int8
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Int8
forall a. String -> Result a
mkError "Unable to read Int8"

instance JSON Int16 where
  showJSON :: Int16 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Int16 -> Rational) -> Int16 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Int16
readJSON (JSRational _ i :: Rational
i) = Int16 -> Result Int16
forall (m :: * -> *) a. Monad m => a -> m a
return (Int16 -> Result Int16) -> Int16 -> Result Int16
forall a b. (a -> b) -> a -> b
$ Rational -> Int16
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Int16
forall a. String -> Result a
mkError "Unable to read Int16"

instance JSON Int32 where
  showJSON :: Int32 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Int32 -> Rational) -> Int32 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Int32
readJSON (JSRational _ i :: Rational
i) = Int32 -> Result Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> Result Int32) -> Int32 -> Result Int32
forall a b. (a -> b) -> a -> b
$ Rational -> Int32
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _             = String -> Result Int32
forall a. String -> Result a
mkError "Unable to read Int32"

instance JSON Int64 where
  showJSON :: Int64 -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Int64 -> Rational) -> Int64 -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  readJSON :: JSValue -> Result Int64
readJSON (JSRational _ i :: Rational
i) = Int64 -> Result Int64
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> Result Int64) -> Int64 -> Result Int64
forall a b. (a -> b) -> a -> b
$ Rational -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
i
  readJSON _                = String -> Result Int64
forall a. String -> Result a
mkError "Unable to read Int64"

-- -----------------------------------------------------------------

instance JSON Double where
  showJSON :: Double -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
False (Rational -> JSValue) -> (Double -> Rational) -> Double -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational
  readJSON :: JSValue -> Result Double
readJSON (JSRational _ r :: Rational
r) = Double -> Result Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Result Double) -> Double -> Result Double
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
  readJSON _                = String -> Result Double
forall a. String -> Result a
mkError "Unable to read Double"
    -- can't use JSRational here, due to ambiguous '0' parse
    -- it will parse as Integer.

instance JSON Float where
  showJSON :: Float -> JSValue
showJSON = Bool -> Rational -> JSValue
JSRational Bool
True (Rational -> JSValue) -> (Float -> Rational) -> Float -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Rational
forall a. Real a => a -> Rational
toRational
  readJSON :: JSValue -> Result Float
readJSON (JSRational _ r :: Rational
r) = Float -> Result Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Result Float) -> Float -> Result Float
forall a b. (a -> b) -> a -> b
$ Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r
  readJSON _                = String -> Result Float
forall a. String -> Result a
mkError "Unable to read Float"

-- -----------------------------------------------------------------
-- Sums

instance (JSON a) => JSON (Maybe a) where
  readJSON :: JSValue -> Result (Maybe a)
readJSON (JSObject o :: JSObject JSValue
o) = case "Just" String -> [(String, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, JSValue)]
as of
      Just x :: JSValue
x -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Result a -> Result (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
x
      _      -> case ("Nothing" String -> [(String, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, JSValue)]
as) of
          Just JSNull -> Maybe a -> Result (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
          _           -> String -> Result (Maybe a)
forall a. String -> Result a
mkError "Unable to read Maybe"
    where as :: [(String, JSValue)]
as = JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o
  readJSON _ = String -> Result (Maybe a)
forall a. String -> Result a
mkError "Unable to read Maybe"
  showJSON :: Maybe a -> JSValue
showJSON (Just x :: a
x) = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue) -> JSObject JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject [("Just", a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
x)]
  showJSON Nothing  = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue) -> JSObject JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject [("Nothing", JSValue
JSNull)]

instance (JSON a, JSON b) => JSON (Either a b) where
  readJSON :: JSValue -> Result (Either a b)
readJSON (JSObject o :: JSObject JSValue
o) = case "Left" String -> [(String, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, JSValue)]
as of
      Just a :: JSValue
a  -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Result a -> Result (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
      Nothing -> case "Right" String -> [(String, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, JSValue)]
as of
          Just b :: JSValue
b  -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Result b -> Result (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
b
          Nothing -> String -> Result (Either a b)
forall a. String -> Result a
mkError "Unable to read Either"
    where as :: [(String, JSValue)]
as = JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o
  readJSON _ = String -> Result (Either a b)
forall a. String -> Result a
mkError "Unable to read Either"
  showJSON :: Either a b -> JSValue
showJSON (Left a :: a
a)  = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue) -> JSObject JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject [("Left",  a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
a)]
  showJSON (Right b :: b
b) = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue) -> JSObject JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject [("Right", b -> JSValue
forall a. JSON a => a -> JSValue
showJSON b
b)]

-- -----------------------------------------------------------------
-- Products

instance JSON () where
  showJSON :: () -> JSValue
showJSON _ = [JSValue] -> JSValue
JSArray []
  readJSON :: JSValue -> Result ()
readJSON (JSArray []) = () -> Result ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  readJSON _      = String -> Result ()
forall a. String -> Result a
mkError "Unable to read ()"

instance (JSON a, JSON b) => JSON (a,b) where
  showJSON :: (a, b) -> JSValue
showJSON (a :: a
a,b :: b
b) = [JSValue] -> JSValue
JSArray [ a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
a, b -> JSValue
forall a. JSON a => a -> JSValue
showJSON b
b ]
  readJSON :: JSValue -> Result (a, b)
readJSON (JSArray [a :: JSValue
a,b :: JSValue
b]) = (,) (a -> b -> (a, b)) -> Result a -> Result (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a Result (b -> (a, b)) -> Result b -> Result (a, b)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
b
  readJSON _ = String -> Result (a, b)
forall a. String -> Result a
mkError "Unable to read Pair"

instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where
  showJSON :: (a, b, c) -> JSValue
showJSON (a :: a
a,b :: b
b,c :: c
c) = [JSValue] -> JSValue
JSArray [ a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
a, b -> JSValue
forall a. JSON a => a -> JSValue
showJSON b
b, c -> JSValue
forall a. JSON a => a -> JSValue
showJSON c
c ]
  readJSON :: JSValue -> Result (a, b, c)
readJSON (JSArray [a :: JSValue
a,b :: JSValue
b,c :: JSValue
c]) = (,,) (a -> b -> c -> (a, b, c))
-> Result a -> Result (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                  JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a Result (b -> c -> (a, b, c)) -> Result b -> Result (c -> (a, b, c))
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
b Result (c -> (a, b, c)) -> Result c -> Result (a, b, c)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  JSValue -> Result c
forall a. JSON a => JSValue -> Result a
readJSON JSValue
c
  readJSON _ = String -> Result (a, b, c)
forall a. String -> Result a
mkError "Unable to read Triple"

instance (JSON a, JSON b, JSON c, JSON d) => JSON (a,b,c,d) where
  showJSON :: (a, b, c, d) -> JSValue
showJSON (a :: a
a,b :: b
b,c :: c
c,d :: d
d) = [JSValue] -> JSValue
JSArray [a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
a, b -> JSValue
forall a. JSON a => a -> JSValue
showJSON b
b, c -> JSValue
forall a. JSON a => a -> JSValue
showJSON c
c, d -> JSValue
forall a. JSON a => a -> JSValue
showJSON d
d]
  readJSON :: JSValue -> Result (a, b, c, d)
readJSON (JSArray [a :: JSValue
a,b :: JSValue
b,c :: JSValue
c,d :: JSValue
d]) = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Result a -> Result (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                  JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a Result (b -> c -> d -> (a, b, c, d))
-> Result b -> Result (c -> d -> (a, b, c, d))
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
b Result (c -> d -> (a, b, c, d))
-> Result c -> Result (d -> (a, b, c, d))
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  JSValue -> Result c
forall a. JSON a => JSValue -> Result a
readJSON JSValue
c Result (d -> (a, b, c, d)) -> Result d -> Result (a, b, c, d)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  JSValue -> Result d
forall a. JSON a => JSValue -> Result a
readJSON JSValue
d

  readJSON _ = String -> Result (a, b, c, d)
forall a. String -> Result a
mkError "Unable to read 4 tuple"

-- -----------------------------------------------------------------
-- List-like types


instance JSON a => JSON [a] where
  showJSON :: [a] -> JSValue
showJSON = [a] -> JSValue
forall a. JSON a => [a] -> JSValue
showJSONs
  readJSON :: JSValue -> Result [a]
readJSON = JSValue -> Result [a]
forall a. JSON a => JSValue -> Result [a]
readJSONs

-- container types:

#if !defined(MAP_AS_DICT)
instance (Ord a, JSON a, JSON b) => JSON (M.Map a b) where
  showJSON :: Map a b -> JSValue
showJSON = (Map a b -> [(a, b)]) -> Map a b -> JSValue
forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
M.toList
  readJSON :: JSValue -> Result (Map a b)
readJSON = String -> ([(a, b)] -> Map a b) -> JSValue -> Result (Map a b)
forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray "Map" [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

instance (JSON a) => JSON (IntMap.IntMap a) where
  showJSON :: IntMap a -> JSValue
showJSON = (IntMap a -> [(Int, a)]) -> IntMap a -> JSValue
forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList
  readJSON :: JSValue -> Result (IntMap a)
readJSON = String -> ([(Int, a)] -> IntMap a) -> JSValue -> Result (IntMap a)
forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray "IntMap" [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IntMap.fromList

#else
instance (Ord a, JSKey a, JSON b) => JSON (M.Map a b) where
  showJSON    = encJSDict . M.toList
  readJSON o  = M.fromList <$> decJSDict "Map" o

instance (JSON a) => JSON (IntMap.IntMap a) where
  {- alternate (dict) mapping: -}
  showJSON    = encJSDict . IntMap.toList
  readJSON o  = IntMap.fromList <$> decJSDict "IntMap" o
#endif


instance (Ord a, JSON a) => JSON (Set.Set a) where
  showJSON :: Set a -> JSValue
showJSON = (Set a -> [a]) -> Set a -> JSValue
forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray Set a -> [a]
forall a. Set a -> [a]
Set.toList
  readJSON :: JSValue -> Result (Set a)
readJSON = String -> ([a] -> Set a) -> JSValue -> Result (Set a)
forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray "Set" [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList

instance (Array.Ix i, JSON i, JSON e) => JSON (Array.Array i e) where
  showJSON :: Array i e -> JSValue
showJSON = (Array i e -> [(i, e)]) -> Array i e -> JSValue
forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray Array i e -> [(i, e)]
forall i e. Ix i => Array i e -> [(i, e)]
Array.assocs
  readJSON :: JSValue -> Result (Array i e)
readJSON = String -> ([(i, e)] -> Array i e) -> JSValue -> Result (Array i e)
forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray "Array" [(i, e)] -> Array i e
forall i e. Ix i => [(i, e)] -> Array i e
arrayFromList

instance JSON I.IntSet where
  showJSON :: IntSet -> JSValue
showJSON = (IntSet -> [Int]) -> IntSet -> JSValue
forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray IntSet -> [Int]
I.toList
  readJSON :: JSValue -> Result IntSet
readJSON = String -> ([Int] -> IntSet) -> JSValue -> Result IntSet
forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray "IntSet" [Int] -> IntSet
I.fromList

-- helper functions for array / object serializers:
arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e
arrayFromList :: [(i, e)] -> Array i e
arrayFromList [] = (i, i) -> [(i, e)] -> Array i e
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (i, i)
forall a. HasCallStack => a
undefined []
arrayFromList ls :: [(i, e)]
ls@((i :: i
i,_):xs :: [(i, e)]
xs) = (i, i) -> [(i, e)] -> Array i e
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (i, i)
bnds [(i, e)]
ls
  where
  bnds :: (i, i)
bnds = ((i, e) -> (i, i) -> (i, i)) -> (i, i) -> [(i, e)] -> (i, i)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (i, e) -> (i, i) -> (i, i)
forall b b. Ord b => (b, b) -> (b, b) -> (b, b)
step (i
i,i
i) [(i, e)]
xs

  step :: (b, b) -> (b, b) -> (b, b)
step (ix :: b
ix,_) (mi :: b
mi,ma :: b
ma) =
    let mi1 :: b
mi1 = b -> b -> b
forall a. Ord a => a -> a -> a
min b
ix b
mi
        ma1 :: b
ma1 = b -> b -> b
forall a. Ord a => a -> a -> a
max b
ix b
ma
    in b
mi1 b -> (b, b) -> (b, b)
forall a b. a -> b -> b
`seq` b
ma1 b -> (b, b) -> (b, b)
forall a b. a -> b -> b
`seq` (b
mi1,b
ma1)


-- -----------------------------------------------------------------
-- ByteStrings

instance JSON S.ByteString where
  showJSON :: ByteString -> JSValue
showJSON = (ByteString -> String) -> ByteString -> JSValue
forall a. (a -> String) -> a -> JSValue
encJSString ByteString -> String
S.unpack
  readJSON :: JSValue -> Result ByteString
readJSON = String
-> (String -> Result ByteString) -> JSValue -> Result ByteString
forall a. String -> (String -> Result a) -> JSValue -> Result a
decJSString "ByteString" (ByteString -> Result ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Result ByteString)
-> (String -> ByteString) -> String -> Result ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S.pack)

instance JSON L.ByteString where
  showJSON :: ByteString -> JSValue
showJSON = (ByteString -> String) -> ByteString -> JSValue
forall a. (a -> String) -> a -> JSValue
encJSString ByteString -> String
L.unpack
  readJSON :: JSValue -> Result ByteString
readJSON = String
-> (String -> Result ByteString) -> JSValue -> Result ByteString
forall a. String -> (String -> Result a) -> JSValue -> Result a
decJSString "Lazy.ByteString" (ByteString -> Result ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Result ByteString)
-> (String -> ByteString) -> String -> Result ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
L.pack)

-- -----------------------------------------------------------------
-- Data.Text

instance JSON T.Text where
  readJSON :: JSValue -> Result Text
readJSON (JSString s :: JSString
s) = Text -> Result Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack (String -> Text) -> (JSString -> String) -> JSString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> String
fromJSString (JSString -> Text) -> JSString -> Text
forall a b. (a -> b) -> a -> b
$ JSString
s)
  readJSON _            = String -> Result Text
forall a. String -> Result a
mkError "Unable to read JSString"
  showJSON :: Text -> JSValue
showJSON              = JSString -> JSValue
JSString (JSString -> JSValue) -> (Text -> JSString) -> Text -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString (String -> JSString) -> (Text -> String) -> Text -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack


-- -----------------------------------------------------------------
-- Instance Helpers

makeObj :: [(String, JSValue)] -> JSValue
makeObj :: [(String, JSValue)] -> JSValue
makeObj = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue)
-> ([(String, JSValue)] -> JSObject JSValue)
-> [(String, JSValue)]
-> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, JSValue)] -> JSObject JSValue
forall a. [(String, a)] -> JSObject a
toJSObject

-- | Pull a value out of a JSON object.
valFromObj :: JSON a => String -> JSObject JSValue -> Result a
valFromObj :: String -> JSObject JSValue -> Result a
valFromObj k :: String
k o :: JSObject JSValue
o = Result a -> (JSValue -> Result a) -> Maybe JSValue -> Result a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Result a
forall a. String -> Result a
Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ "valFromObj: Could not find key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
k)
                       JSValue -> Result a
forall a. JSON a => JSValue -> Result a
readJSON
                       (String -> [(String, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k (JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o))

encJSString :: (a -> String) -> a -> JSValue
encJSString :: (a -> String) -> a -> JSValue
encJSString f :: a -> String
f v :: a
v = JSString -> JSValue
JSString (String -> JSString
toJSString (a -> String
f a
v))

decJSString :: String -> (String -> Result a) -> JSValue -> Result a
decJSString :: String -> (String -> Result a) -> JSValue -> Result a
decJSString _ f :: String -> Result a
f (JSString s :: JSString
s) = String -> Result a
f (JSString -> String
fromJSString JSString
s)
decJSString l :: String
l _ _ = String -> Result a
forall a. String -> Result a
mkError ("readJSON{"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++"}: unable to parse string value")

encJSArray :: (JSON a) => (b-> [a]) -> b -> JSValue
encJSArray :: (b -> [a]) -> b -> JSValue
encJSArray f :: b -> [a]
f v :: b
v = [a] -> JSValue
forall a. JSON a => a -> JSValue
showJSON (b -> [a]
f b
v)

decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b
decJSArray :: String -> ([a] -> b) -> JSValue -> Result b
decJSArray _ f :: [a] -> b
f a :: JSValue
a@JSArray{} = [a] -> b
f ([a] -> b) -> Result [a] -> Result b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> Result [a]
forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
decJSArray l :: String
l _ _ = String -> Result b
forall a. String -> Result a
mkError ("readJSON{"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++"}: unable to parse array value")

-- | Haskell types that can be used as keys in JSON objects.
class JSKey a where
  toJSKey   :: a -> String
  fromJSKey :: String -> Maybe a

instance JSKey JSString where
  toJSKey :: JSString -> String
toJSKey x :: JSString
x   = JSString -> String
fromJSString JSString
x
  fromJSKey :: String -> Maybe JSString
fromJSKey x :: String
x = JSString -> Maybe JSString
forall a. a -> Maybe a
Just (String -> JSString
toJSString String
x)

instance JSKey Int where
  toJSKey :: Int -> String
toJSKey   = Int -> String
forall a. Show a => a -> String
show
  fromJSKey :: String -> Maybe Int
fromJSKey key :: String
key = case ReadS Int
forall a. Read a => ReadS a
reads String
key of
                    [(a :: Int
a,"")] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
a
                    _        -> Maybe Int
forall a. Maybe a
Nothing

-- NOTE: This prevents us from making other instances for lists but,
-- our guess is that strings are used as keys more often then other list types.
instance JSKey String where
  toJSKey :: String -> String
toJSKey   = String -> String
forall a. a -> a
id
  fromJSKey :: String -> Maybe String
fromJSKey = String -> Maybe String
forall a. a -> Maybe a
Just
  
-- | Encode an association list as 'JSObject' value.
encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue
encJSDict :: [(a, b)] -> JSValue
encJSDict v :: [(a, b)]
v = [(String, JSValue)] -> JSValue
makeObj [ (a -> String
forall a. JSKey a => a -> String
toJSKey a
x, b -> JSValue
forall a. JSON a => a -> JSValue
showJSON b
y) | (x :: a
x,y :: b
y) <- [(a, b)]
v ]

-- | Decode a 'JSObject' value into an association list.
decJSDict :: (JSKey a, JSON b)
          => String
          -> JSValue
          -> Result [(a,b)]
decJSDict :: String -> JSValue -> Result [(a, b)]
decJSDict l :: String
l (JSObject o :: JSObject JSValue
o) = ((String, JSValue) -> Result (a, b))
-> [(String, JSValue)] -> Result [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, JSValue) -> Result (a, b)
forall a b. (JSKey a, JSON b) => (String, JSValue) -> Result (a, b)
rd (JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o)
  where rd :: (String, JSValue) -> Result (a, b)
rd (a :: String
a,b :: JSValue
b) = case String -> Maybe a
forall a. JSKey a => String -> Maybe a
fromJSKey String
a of
                     Just pa :: a
pa -> JSValue -> Result b
forall a. JSON a => JSValue -> Result a
readJSON JSValue
b Result b -> (b -> Result (a, b)) -> Result (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pb :: b
pb -> (a, b) -> Result (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
pa,b
pb)
                     Nothing -> String -> Result (a, b)
forall a. String -> Result a
mkError ("readJSON{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    "unable to read dict; invalid object key")

decJSDict l :: String
l _ = String -> Result [(a, b)]
forall a. String -> Result a
mkError ("readJSON{"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}: unable to read dict; expected JSON object")