module Data.Json.Serialiser
(
serialiseJsonBs, serialiseJsonBsl, serialiseJsonT
, ToJson(..)
, runSerSpec, SerSpec(..), (.<-), KeyedSerialiser, SerObjSpec(..)
, SpecKey, (.:), (.:?)
, ObjectBuilder, emptyObject, Value, (.=), (.=#), row, array, nullValue
)
where
import Data.BufferBuilder.Json
import Data.Int
import Data.Monoid
import Data.Typeable
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
instance (ToJson a, ToJson b) => ToJson (Either a b) where
toJson x =
case x of
Left y -> toJson y
Right z -> toJson z
instance (ToJson a, ToJson b) => ToJson (a, b) where
toJson (x, y) = toJson [ toJson x, toJson y ]
instance ToJson Int64 where
toJson i =
let j :: Int
j = fromIntegral i
in toJson j
data SpecKey k t
= SpecKey
{ k_key :: !T.Text
, k_getVal :: !(k -> Maybe t)
}
(.:) :: (ToJson t, Typeable t) => T.Text -> (k -> t) -> SpecKey k t
k .: getter = SpecKey k (Just . getter)
(.:?) :: (ToJson t, Typeable t) => T.Text -> (k -> Maybe t) -> SpecKey k (Maybe t)
k .:? getter =
SpecKey k $ \obj ->
let val = getter obj
in case val of
Nothing -> Nothing
Just _ -> Just val
newtype KeyedSerialiser k
= KeyedSerialiser { unKeyedSerialiser :: Value }
(.<-) :: ToJson a => T.Text -> a -> KeyedSerialiser k
a .<- b = KeyedSerialiser $ toJson (a .= b)
data SerSpec k where
SingleConstr :: SerObjSpec k ts -> SerSpec k
MultiConstr :: (k -> KeyedSerialiser k) -> SerSpec k
runSerSpec :: SerSpec k -> k -> Value
runSerSpec spec input =
case spec of
SingleConstr fullSpec -> runSerObjSpec fullSpec input
MultiConstr getVal -> unKeyedSerialiser $ getVal input
data SerObjSpec k (ts :: [*]) where
SerObjSpecNil :: SerObjSpec k '[]
(:&&&:) :: (ToJson t, Typeable t) => !(SpecKey k t) -> !(SerObjSpec k ts) -> SerObjSpec k (t ': ts)
infixr 5 :&&&:
runSerObjSpec :: SerObjSpec k ts -> k -> Value
runSerObjSpec spec input = toJson (buildSpec spec input)
buildSpec :: SerObjSpec k ts -> k -> ObjectBuilder
buildSpec spec input =
case spec of
SerObjSpecNil -> mempty
(SpecKey key getVal :&&&: xs) ->
case getVal input of
Nothing -> buildSpec xs input
Just val -> key .= getVal input <> buildSpec xs input
serialiseJsonBs :: ToJson a => a -> BS.ByteString
serialiseJsonBs = encodeJson
serialiseJsonBsl :: ToJson a => a -> BSL.ByteString
serialiseJsonBsl = BSL.fromStrict . serialiseJsonBs
serialiseJsonT :: ToJson a => a -> T.Text
serialiseJsonT = T.decodeUtf8 . serialiseJsonBs