module JSONEncoder
(
run,
Value,
null,
boolean,
number_integral,
number_scientific,
string,
object,
array,
nullable,
Object,
field,
row,
Array,
homo,
hetero,
Hetero,
element,
)
where
import JSONEncoder.Prelude hiding (length, null)
import qualified ByteString.TreeBuilder as Builders
import qualified JSONEncoder.Builders as Builders
import qualified Data.Scientific
run :: Value a -> a -> Builders.Builder
run (Value (Op producer)) input =
producer input
newtype Value a =
Value (Op Builders.Builder a)
deriving (Contravariant, Divisible, Decidable)
null :: Value ()
null =
Value $ Op $
const "null"
boolean :: Value Bool
boolean =
Value $ Op $
\case
True -> "true"
False -> "false"
number_integral :: Integral a => Value a
number_integral =
Value $ Op $
Builders.asciiIntegral
number_scientific :: Value Data.Scientific.Scientific
number_scientific =
Value $ Op $
fromString . show
string :: Value Text
string =
Value $ Op $
Builders.stringLiteral
object :: Object a -> Value a
object (Object (Op sectionsProducer)) =
Value $ Op $
sectionsProducer >>>
mappend (Builders.asciiChar '{') >>>
flip mappend (Builders.asciiChar '}')
array :: Array a -> Value a
array (Array (Op sectionsProducer)) =
Value $ Op $
sectionsProducer >>>
mappend (Builders.asciiChar '[') >>>
flip mappend (Builders.asciiChar ']')
nullable :: Value a -> Value (Maybe a)
nullable =
choose (maybe (Left ()) Right) null
newtype Object a =
Object (Op Builders.Builder a)
deriving (Contravariant)
instance Divisible Object where
conquer =
mempty
divide divisor (Object (Op producer1)) (Object (Op producer2)) =
Object $ Op $
divisor >>> \(input1, input2) ->
Builders.appendWithIncut (Builders.asciiChar ',') (producer1 input1) (producer2 input2)
instance Decidable Object where
lose f =
Object (lose f)
choose f (Object op1) (Object op2) =
Object (choose f op1 op2)
instance Monoid (Object a) where
mempty =
Object (Op (const mempty))
mappend (Object (Op producer1)) (Object (Op producer2)) =
Object (Op (Builders.appendWithIncut (Builders.asciiChar ',') <$> producer1 <*> producer2))
instance Semigroup (Object a)
field :: Text -> Value a -> Object a
field name (Value (Op producer)) =
Object $ Op $
producer >>>
mappend (Builders.asciiChar ':') >>>
mappend (Builders.stringLiteral name)
row :: Value a -> Object (Text, a)
row (Value (Op valueProducer)) =
Object (Op producer)
where
producer (key, value) =
Builders.stringLiteral key <>
Builders.asciiChar ':' <>
valueProducer value
newtype Array a =
Array (Op Builders.Builder a)
deriving (Contravariant)
homo :: (forall a. (a -> b -> a) -> a -> c -> a) -> Value b -> Array c
homo foldl (Value (Op producer)) =
Array (Op arrayProducer)
where
arrayProducer =
foldl step mempty
where
step acc =
Builders.appendWithIncut (Builders.asciiChar ',') acc .
producer
hetero :: Hetero a -> Array a
hetero (Hetero op) =
Array op
newtype Hetero a =
Hetero (Op Builders.Builder a)
deriving (Contravariant)
instance Divisible Hetero where
conquer =
mempty
divide divisor (Hetero (Op producer1)) (Hetero (Op producer2)) =
Hetero $ Op $
divisor >>> \(input1, input2) ->
Builders.appendWithIncut (Builders.asciiChar ',') (producer1 input1) (producer2 input2)
instance Decidable Hetero where
lose f =
Hetero (lose f)
choose f (Hetero op1) (Hetero op2) =
Hetero (choose f op1 op2)
instance Monoid (Hetero a) where
mempty =
Hetero (Op (const mempty))
mappend (Hetero (Op producer1)) (Hetero (Op producer2)) =
Hetero (Op (Builders.appendWithIncut (Builders.asciiChar ',') <$> producer1 <*> producer2))
instance Semigroup (Hetero a)
element :: Value a -> Hetero a
element (Value op) =
Hetero op