{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Waargonaut.Encode
(
Encoder
, Encoder'
, ObjEncoder
, ObjEncoder'
, encodeA
, encodePureA
, jsonEncoder
, objEncoder
, runPureEncoder
, runEncoder
, simpleEncodeNoSpaces
, simplePureEncodeNoSpaces
, int
, integral
, scientific
, bool
, string
, text
, null
, either
, maybe
, maybeOrNull
, traversable
, list
, nonempty
, mapToObj
, json
, prismE
, mapLikeObj
, atKey
, intAt
, textAt
, boolAt
, traversableAt
, listAt
, nonemptyAt
, encAt
, keyValuesAsObj
, onObj
, keyValueTupleFoldable
, extendObject
, extendMapLikeObject
, combineObjects
, int'
, integral'
, scientific'
, bool'
, string'
, text'
, null'
, either'
, maybe'
, maybeOrNull'
, traversable'
, nonempty'
, list'
, atKey'
, mapLikeObj'
, mapToObj'
, keyValuesAsObj'
, json'
, generaliseEncoder
) where
import Control.Applicative (Applicative (..), (<$>))
import Control.Category (id, (.))
import Control.Lens (AReview, At, Index,
IxValue, Prism', at,
cons, review, ( # ),
(?~), _Empty, _Wrapped)
import qualified Control.Lens as L
import Prelude (Bool, Int, Integral,
Monad, String,
fromIntegral, fst)
import Data.Foldable (Foldable, foldr, foldrM)
import Data.Function (const, flip, ($), (&))
import Data.Functor (Functor, fmap)
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Contravariant.Divisible (divide)
import Data.Functor.Identity (Identity (..))
import Data.Traversable (Traversable, traverse)
import Data.Either (Either)
import qualified Data.Either as Either
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (Maybe)
import qualified Data.Maybe as Maybe
import Data.Scientific (Scientific)
import Data.Monoid (Monoid, mempty)
import Data.Semigroup (Semigroup)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TB
import Waargonaut.Encode.Types (Encoder, Encoder',
ObjEncoder, ObjEncoder',
finaliseEncoding,
generaliseEncoder,
initialEncoding,
jsonEncoder, objEncoder,
runEncoder,
runPureEncoder)
import Waargonaut.Types (AsJType (..),
JAssoc (..), JObject,
Json, MapLikeObj (..),
WS, stringToJString,
toMapLikeObj, wsRemover,
_JNumberInt,
_JNumberScientific,
_JStringText)
import Waargonaut.Types.Json (waargonautBuilder)
encodeA :: (a -> f Json) -> Encoder f a
encodeA = jsonEncoder
encodePureA :: (a -> Json) -> Encoder' a
encodePureA f = encodeA (Identity . f)
simpleEncodeNoSpaces
:: Applicative f
=> Encoder f a
-> a
-> f LT.Text
simpleEncodeNoSpaces enc =
fmap (TB.toLazyText . waargonautBuilder wsRemover) . runEncoder enc
simplePureEncodeNoSpaces
:: Encoder Identity a
-> a
-> LT.Text
simplePureEncodeNoSpaces enc =
runIdentity . simpleEncodeNoSpaces enc
json :: Applicative f => Encoder f Json
json = encodeA pure
encToJsonNoSpaces
:: ( Monoid t
, Applicative f
)
=> AReview Json (b, t)
-> (a -> b)
-> Encoder f a
encToJsonNoSpaces c f =
encodeA (pure . review c . (,mempty) . f)
prismE
:: Prism' a b
-> Encoder f a
-> Encoder f b
prismE p e =
L.review p >$< e
int :: Applicative f => Encoder f Int
int = encToJsonNoSpaces _JNum (_JNumberInt #)
scientific :: Applicative f => Encoder f Scientific
scientific = encToJsonNoSpaces _JNum (_JNumberScientific #)
integral :: (Applicative f, Integral n) => Encoder f n
integral = encToJsonNoSpaces _JNum (review _JNumberScientific . fromIntegral)
bool :: Applicative f => Encoder f Bool
bool = encToJsonNoSpaces _JBool id
string :: Applicative f => Encoder f String
string = encToJsonNoSpaces _JStr stringToJString
text :: Applicative f => Encoder f Text
text = encToJsonNoSpaces _JStr (_JStringText #)
null :: Applicative f => Encoder f ()
null = encodeA $ const (pure $ _JNull # mempty)
maybe
:: Functor f
=> Encoder f ()
-> Encoder f a
-> Encoder f (Maybe a)
maybe encN = encodeA
. Maybe.maybe (runEncoder encN ())
. runEncoder
maybeOrNull
:: Applicative f
=> Encoder f a
-> Encoder f (Maybe a)
maybeOrNull =
maybe null
either
:: Functor f
=> Encoder f a
-> Encoder f b
-> Encoder f (Either a b)
either eA = encodeA
. Either.either (runEncoder eA)
. runEncoder
traversable
:: ( Applicative f
, Traversable t
)
=> Encoder f a
-> Encoder f (t a)
traversable = encodeWithInner
(\xs -> _JArr # (_Wrapped # foldr cons mempty xs, mempty))
mapToObj
:: Applicative f
=> Encoder f a
-> (k -> Text)
-> Encoder f (Map k a)
mapToObj encodeVal kToText =
let
mapToCS = Map.foldrWithKey (\k v -> at (kToText k) ?~ v) (_Empty # ())
in
encodeWithInner (\xs -> _JObj # (fromMapLikeObj $ mapToCS xs, mempty)) encodeVal
nonempty
:: Applicative f
=> Encoder f a
-> Encoder f (NonEmpty a)
nonempty =
traversable
list
:: Applicative f
=> Encoder f a
-> Encoder f [a]
list =
traversable
json' :: Encoder' Json
json' = json
int' :: Encoder' Int
int' = int
integral' :: Integral n => Encoder' n
integral' = integral
scientific' :: Encoder' Scientific
scientific' = scientific
bool' :: Encoder' Bool
bool' = bool
string' :: Encoder' String
string' = string
text' :: Encoder' Text
text' = text
null' :: Encoder' ()
null' = null
maybe'
:: Encoder' ()
-> Encoder' a
-> Encoder' (Maybe a)
maybe' =
maybe
maybeOrNull'
:: Encoder' a
-> Encoder' (Maybe a)
maybeOrNull' =
maybeOrNull
either'
:: Encoder' a
-> Encoder' b
-> Encoder' (Either a b)
either' =
either
nonempty'
:: Encoder' a
-> Encoder' (NonEmpty a)
nonempty' =
traversable
list'
:: Encoder' a
-> Encoder' [a]
list' =
traversable
encodeWithInner
:: ( Applicative f
, Traversable t
)
=> (t Json -> Json)
-> Encoder f a
-> Encoder f (t a)
encodeWithInner f g =
jsonEncoder $ fmap f . traverse (runEncoder g)
traversable'
:: Traversable t
=> Encoder' a
-> Encoder' (t a)
traversable' =
traversable
mapToObj'
:: Encoder' a
-> (k -> Text)
-> Encoder' (Map k a)
mapToObj' =
mapToObj
atKey
:: ( At t
, IxValue t ~ Json
, Applicative f
)
=> Index t
-> Encoder f a
-> a
-> t
-> f t
atKey k enc v t =
(\v' -> t & at k ?~ v') <$> runEncoder enc v
atKey'
:: ( At t
, IxValue t ~ Json
)
=> Index t
-> Encoder' a
-> a
-> t
-> t
atKey' k enc v =
at k ?~ runIdentity (runEncoder enc v)
intAt
:: Text
-> Int
-> MapLikeObj WS Json
-> MapLikeObj WS Json
intAt =
flip atKey' int
textAt
:: Text
-> Text
-> MapLikeObj WS Json
-> MapLikeObj WS Json
textAt =
flip atKey' text
boolAt
:: Text
-> Bool
-> MapLikeObj WS Json
-> MapLikeObj WS Json
boolAt =
flip atKey' bool
traversableAt
:: ( At t
, Traversable f
, IxValue t ~ Json
)
=> Encoder' a
-> Index t
-> f a
-> t
-> t
traversableAt enc =
flip atKey' (traversable enc)
listAt
:: ( At t
, IxValue t ~ Json
)
=> Encoder' a
-> Index t
-> [a]
-> t
-> t
listAt =
traversableAt
nonemptyAt
:: ( At t
, IxValue t ~ Json
)
=> Encoder' a
-> Index t
-> NonEmpty a
-> t
-> t
nonemptyAt =
traversableAt
mapLikeObj
:: ( AsJType Json ws a
, Monoid ws
, Semigroup ws
, Applicative f
)
=> (i -> MapLikeObj ws a -> MapLikeObj ws a)
-> Encoder f i
mapLikeObj f = encodeA $ \a ->
pure $ _JObj # (fromMapLikeObj $ f a (_Empty # ()), mempty)
mapLikeObj'
:: ( AsJType Json ws a
, Semigroup ws
, Monoid ws
)
=> (i -> MapLikeObj ws a -> MapLikeObj ws a)
-> Encoder' i
mapLikeObj' f = encodePureA $ \a ->
_JObj # (fromMapLikeObj $ f a (_Empty # ()), mempty)
extendObject
:: Functor f
=> ObjEncoder f a
-> a
-> (JObject WS Json -> JObject WS Json)
-> f Json
extendObject encA a f =
finaliseEncoding encA . f <$> initialEncoding encA a
extendMapLikeObject
:: Functor f
=> ObjEncoder f a
-> a
-> (MapLikeObj WS Json -> MapLikeObj WS Json)
-> f Json
extendMapLikeObject encA a f =
finaliseEncoding encA . floopObj <$> initialEncoding encA a
where
floopObj = fromMapLikeObj . f . fst . toMapLikeObj
combineObjects
:: Applicative f
=> (a -> (b, c))
-> ObjEncoder f b
-> ObjEncoder f c
-> ObjEncoder f a
combineObjects f eB eC =
divide f eB eC
onObj
:: Applicative f
=> Text
-> b
-> Encoder f b
-> JObject WS Json
-> f (JObject WS Json)
onObj k b encB o = (\j -> o & _Wrapped L.%~ L.cons j)
. JAssoc (_JStringText # k) mempty mempty <$> runEncoder encB b
keyValuesAsObj
:: ( Foldable g
, Monad f
)
=> g (a -> JObject WS Json -> f (JObject WS Json))
-> Encoder f a
keyValuesAsObj xs = encodeA $ \a ->
(\v -> _JObj # (v,mempty)) <$> foldrM (\f -> f a) (_Empty # ()) xs
keyValueTupleFoldable
:: ( Monad f
, Foldable g
)
=> Encoder f a
-> Encoder f (g (Text, a))
keyValueTupleFoldable eA = encodeA $ \xs ->
(\v -> _JObj # (v,mempty)) <$> foldrM (\(k,v) o -> onObj k v eA o) (_Empty # ()) xs
keyValuesAsObj'
:: ( Foldable g
, Functor g
)
=> g (a -> JObject WS Json -> JObject WS Json)
-> Encoder' a
keyValuesAsObj' =
keyValuesAsObj . fmap (\f a -> Identity . f a)
encAt
:: Applicative f
=> Encoder f b
-> Text
-> (a -> b)
-> a
-> JObject WS Json
-> f (JObject WS Json)
encAt e k f a =
onObj k (f a) e