{-# 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 Control.Monad.Fail (MonadFail (..))
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 :: forall a. JSON a => String -> Result a
decode String
s = case forall a. GetJSON a -> String -> Either String a
runGetJSON GetJSON JSValue
readJSValue String
s of
             Right JSValue
a  -> forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
             Left String
err -> 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 :: forall a. JSON a => a -> String
encode = (forall a b c. (a -> b -> c) -> b -> a -> c
flip JSValue -> ShowS
showJSValue [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. JSON a => String -> Result a
decodeStrict String
s = case forall a. GetJSON a -> String -> Either String a
runGetJSON GetJSON JSValue
readJSTopType String
s of
     Right JSValue
a  -> forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
     Left String
err -> 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 :: forall a. JSON a => a -> String
encodeStrict = (forall a b c. (a -> b -> c) -> b -> a -> c
flip JSValue -> ShowS
showJSTopType [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [JSValue]
as) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. JSON a => JSValue -> Result a
readJSON [JSValue]
as
  readJSONs JSValue
_            = forall a. String -> Result a
mkError String
"Unable to read list"

  showJSONs :: [a] -> JSValue
  showJSONs = [JSValue] -> JSValue
JSArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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
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 -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show)

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

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

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

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

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

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

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

-- | Convenient error generation
mkError :: String -> Result a
mkError :: forall a. String -> Result a
mkError String
s = 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 = forall a. a -> a
id
    readJSON :: JSValue -> Result JSValue
readJSON = forall (m :: * -> *) a. Monad m => a -> m a
return

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

instance (JSON a, JSON b, JSON c) => JSON (a,b,c) where
  showJSON :: (a, b, c) -> JSValue
showJSON (a
a,b
b,c
c) = [JSValue] -> JSValue
JSArray [ forall a. JSON a => a -> JSValue
showJSON a
a, forall a. JSON a => a -> JSValue
showJSON b
b, forall a. JSON a => a -> JSValue
showJSON c
c ]
  readJSON :: JSValue -> Result (a, b, c)
readJSON (JSArray [JSValue
a,JSValue
b,JSValue
c]) = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
a forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
b forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
c
  readJSON JSValue
_ = forall a. String -> Result a
mkError String
"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,b
b,c
c,d
d) = [JSValue] -> JSValue
JSArray [forall a. JSON a => a -> JSValue
showJSON a
a, forall a. JSON a => a -> JSValue
showJSON b
b, forall a. JSON a => a -> JSValue
showJSON c
c, forall a. JSON a => a -> JSValue
showJSON d
d]
  readJSON :: JSValue -> Result (a, b, c, d)
readJSON (JSArray [JSValue
a,JSValue
b,JSValue
c,JSValue
d]) = (,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
a forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
b forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
c forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap`
                                  forall a. JSON a => JSValue -> Result a
readJSON JSValue
d

  readJSON JSValue
_ = forall a. String -> Result a
mkError String
"Unable to read 4 tuple"

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


instance JSON a => JSON [a] where
  showJSON :: [a] -> JSValue
showJSON = forall a. JSON a => [a] -> JSValue
showJSONs
  readJSON :: JSValue -> Result [a]
readJSON = 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 = forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray forall k a. Map k a -> [(k, a)]
M.toList
  readJSON :: JSValue -> Result (Map a b)
readJSON = forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray String
"Map" 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 = forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray forall a. IntMap a -> [(Int, a)]
IntMap.toList
  readJSON :: JSValue -> Result (IntMap a)
readJSON = forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray String
"IntMap" 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 = forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray forall a. Set a -> [a]
Set.toList
  readJSON :: JSValue -> Result (Set a)
readJSON = forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray String
"Set" 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 = forall a b. JSON a => (b -> [a]) -> b -> JSValue
encJSArray forall i e. Ix i => Array i e -> [(i, e)]
Array.assocs
  readJSON :: JSValue -> Result (Array i e)
readJSON = forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray String
"Array" forall i e. Ix i => [(i, e)] -> Array i e
arrayFromList

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

-- helper functions for array / object serializers:
arrayFromList :: (Array.Ix i) => [(i,e)] -> Array.Array i e
arrayFromList :: forall i e. Ix i => [(i, e)] -> Array i e
arrayFromList [] = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array forall a. HasCallStack => a
undefined []
arrayFromList ls :: [(i, e)]
ls@((i
i,e
_):[(i, e)]
xs) = 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 (b
ix,b
_) (b
mi,b
ma) =
    let mi1 :: b
mi1 = forall a. Ord a => a -> a -> a
min b
ix b
mi
        ma1 :: b
ma1 = forall a. Ord a => a -> a -> a
max b
ix b
ma
    in b
mi1 seq :: forall a b. a -> b -> b
`seq` b
ma1 seq :: forall a b. a -> b -> b
`seq` (b
mi1,b
ma1)


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

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

instance JSON L.ByteString where
  showJSON :: ByteString -> JSValue
showJSON = forall a. (a -> String) -> a -> JSValue
encJSString ByteString -> String
L.unpack
  readJSON :: JSValue -> Result ByteString
readJSON = forall a. String -> (String -> Result a) -> JSValue -> Result a
decJSString String
"Lazy.ByteString" (forall (m :: * -> *) a. Monad m => a -> m a
return 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 JSString
s) = forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> String
fromJSString forall a b. (a -> b) -> a -> b
$ JSString
s)
  readJSON JSValue
_            = forall a. String -> Result a
mkError String
"Unable to read JSString"
  showJSON :: Text -> JSValue
showJSON              = JSString -> JSValue
JSString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(String, a)] -> JSObject a
toJSObject

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

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

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

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

decJSArray :: (JSON a) => String -> ([a] -> b) -> JSValue -> Result b
decJSArray :: forall a b. JSON a => String -> ([a] -> b) -> JSValue -> Result b
decJSArray String
_ [a] -> b
f a :: JSValue
a@JSArray{} = [a] -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. JSON a => JSValue -> Result a
readJSON JSValue
a
decJSArray String
l [a] -> b
_ JSValue
_ = forall a. String -> Result a
mkError (String
"readJSON{"forall a. [a] -> [a] -> [a]
++String
lforall a. [a] -> [a] -> [a]
++String
"}: 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 JSString
x   = JSString -> String
fromJSString JSString
x
  fromJSKey :: String -> Maybe JSString
fromJSKey String
x = forall a. a -> Maybe a
Just (String -> JSString
toJSString String
x)

instance JSKey Int where
  toJSKey :: Int -> String
toJSKey   = forall a. Show a => a -> String
show
  fromJSKey :: String -> Maybe Int
fromJSKey String
key = case forall a. Read a => ReadS a
reads String
key of
                    [(Int
a,String
"")] -> forall a. a -> Maybe a
Just Int
a
                    [(Int, String)]
_        -> 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 :: ShowS
toJSKey   = forall a. a -> a
id
  fromJSKey :: String -> Maybe String
fromJSKey = forall a. a -> Maybe a
Just
  
-- | Encode an association list as 'JSObject' value.
encJSDict :: (JSKey a, JSON b) => [(a,b)] -> JSValue
encJSDict :: forall a b. (JSKey a, JSON b) => [(a, b)] -> JSValue
encJSDict [(a, b)]
v = [(String, JSValue)] -> JSValue
makeObj [ (forall a. JSKey a => a -> String
toJSKey a
x, forall a. JSON a => a -> JSValue
showJSON b
y) | (a
x,b
y) <- [(a, b)]
v ]

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

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