{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- JSON backend
--
-- This module provides 'Transport' and 'Atom' instances for JSON.

module Data.Autolib.Transport.JSON (
    -- instances only
) where

import Data.Autolib.Transport.Atom
import Data.Autolib.Transport.Class

import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Data.Text (Text, pack, unpack)
import Control.Arrow (second)

import Text.JSON (
    JSValue (..), fromJSString, toJSString, fromJSObject, toJSObject)
import qualified Codec.Binary.Base64.String as C

-- bools are supported directly
instance ConvertAtom JSValue Bool where
    fromAtom :: JSValue -> Error Bool
fromAtom JSValue
x = do JSBool x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x; return x'
    toAtom :: Bool -> JSValue
toAtom = Bool -> JSValue
JSBool

-- doubles are stored as numbers (which Text.JSON stores a bit oddly)
instance ConvertAtom JSValue Double where
    fromAtom :: JSValue -> Error Double
fromAtom JSValue
x = do JSRational _ x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x; return (fromRational x')
    toAtom :: Double -> JSValue
toAtom = 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

-- integers are stored as numbers as well
instance ConvertAtom JSValue Integer where
    fromAtom :: JSValue -> Error Integer
fromAtom JSValue
x = do JSRational _ x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x; return (truncate x')
    toAtom :: Integer -> JSValue
toAtom = 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. Num a => Integer -> a
fromInteger

-- strings as strings
instance ConvertAtom JSValue String where
    fromAtom :: JSValue -> Error String
fromAtom JSValue
x = do JSString x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x; return (fromJSString x')
    toAtom :: String -> JSValue
toAtom = JSString -> JSValue
JSString (JSString -> JSValue) -> (String -> JSString) -> String -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString

-- text as strings
instance ConvertAtom JSValue Text where
    fromAtom :: JSValue -> Error Text
fromAtom JSValue
x = do JSString x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x; return (pack (fromJSString x'))
    toAtom :: Text -> JSValue
toAtom = 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
unpack

-- and binaries as base64-encoded strings
instance ConvertAtom JSValue ByteString where
    fromAtom :: JSValue -> Error ByteString
fromAtom JSValue
x = do
        JSString x' <- JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x
        return $ B.pack . map (fromIntegral . fromEnum)
               . C.decode . fromJSString $ x'
    toAtom :: ByteString -> JSValue
toAtom = JSString -> JSValue
JSString (JSString -> JSValue)
-> (ByteString -> JSString) -> ByteString -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSString
toJSString (String -> JSString)
-> (ByteString -> String) -> ByteString -> JSString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
C.encode
           (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack

instance Transport JSValue JSValue where
    encode :: Trans JSValue -> JSValue
encode (TrAtom JSValue
x)    = JSValue
x
    encode (TrArray [Trans JSValue]
xs)  = [JSValue] -> JSValue
JSArray ([JSValue] -> JSValue) -> [JSValue] -> JSValue
forall a b. (a -> b) -> a -> b
$ (Trans JSValue -> JSValue) -> [Trans JSValue] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Trans JSValue -> JSValue
forall base atom. Transport base atom => Trans atom -> base
encode [Trans JSValue]
xs
    encode (TrObject [(String, Trans JSValue)]
xs) = JSObject JSValue -> JSValue
JSObject (JSObject JSValue -> JSValue)
-> ([(String, Trans JSValue)] -> JSObject JSValue)
-> [(String, Trans JSValue)]
-> 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)
-> ([(String, Trans JSValue)] -> [(String, JSValue)])
-> [(String, Trans JSValue)]
-> JSObject JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Trans JSValue) -> (String, JSValue))
-> [(String, Trans JSValue)] -> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map ((Trans JSValue -> JSValue)
-> (String, Trans JSValue) -> (String, JSValue)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Trans JSValue -> JSValue
forall base atom. Transport base atom => Trans atom -> base
encode) ([(String, Trans JSValue)] -> JSValue)
-> [(String, Trans JSValue)] -> JSValue
forall a b. (a -> b) -> a -> b
$ [(String, Trans JSValue)]
xs

    decode :: JSValue -> Error (Trans JSValue)
decode (JSArray [JSValue]
xs) = [Trans JSValue] -> Trans JSValue
forall atom. [Trans atom] -> Trans atom
TrArray ([Trans JSValue] -> Trans JSValue)
-> Error [Trans JSValue] -> Error (Trans JSValue)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (JSValue -> Error (Trans JSValue))
-> [JSValue] -> Error [Trans JSValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM JSValue -> Error (Trans JSValue)
forall base atom. Transport base atom => base -> Error (Trans atom)
decode [JSValue]
xs
    decode (JSObject JSObject JSValue
o) = [(String, Trans JSValue)] -> Trans JSValue
forall atom. [(String, Trans atom)] -> Trans atom
TrObject ([(String, Trans JSValue)] -> Trans JSValue)
-> Error [(String, Trans JSValue)] -> Error (Trans JSValue)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((String, JSValue) -> Error (String, Trans JSValue))
-> [(String, JSValue)] -> Error [(String, Trans JSValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((JSValue -> Error (Trans JSValue))
-> (String, JSValue) -> Error (String, Trans JSValue)
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> (x, a) -> m (x, b)
secondM JSValue -> Error (Trans JSValue)
forall base atom. Transport base atom => base -> Error (Trans atom)
decode) (JSObject JSValue -> [(String, JSValue)]
forall e. JSObject e -> [(String, e)]
fromJSObject JSObject JSValue
o)
    decode JSValue
x            = JSValue -> Trans JSValue
forall atom. atom -> Trans atom
TrAtom (JSValue -> Trans JSValue)
-> Error JSValue -> Error (Trans JSValue)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` JSValue -> Error JSValue
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
x

secondM :: Monad m => (a -> m b) -> (x, a) -> m (x, b)
secondM :: forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> (x, a) -> m (x, b)
secondM a -> m b
f (x
x, a
a) = a -> m b
f a
a m b -> (b -> m (x, b)) -> m (x, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (x, b) -> m (x, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((x, b) -> m (x, b)) -> (b -> (x, b)) -> b -> m (x, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) x
x