{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- |
-- Types and functions that make up the internal structure of the encoders.
--
module Waargonaut.Encode.Types
  ( -- * Types
    EncoderFns (..)

    -- * Useful aliases
  , Encoder
  , Encoder'
  , ObjEncoder
  , ObjEncoder'

    -- * Runners
  , runEncoder
  , runPureEncoder

    -- * Helpers
  , jsonEncoder
  , objEncoder
  , generaliseEncoder
  ) where

import           Control.Monad                        (Monad)
import           Control.Monad.Morph                  (MFunctor (..),
                                                       generalize)

import           Control.Applicative                  (Applicative, liftA2,
                                                       pure)
import           Control.Category                     (id, (.))
import           Control.Lens                         (( # ))

import           Data.Either                          (either)
import           Data.Function                        (const, ($))
import           Data.Functor                         (Functor)
import           Data.Functor.Contravariant           (Contravariant (..))

import           Data.Functor.Contravariant.Divisible (Decidable (..),
                                                       Divisible (..))
import           Data.Monoid                          (mempty)
import           Data.Semigroup                       ((<>))
import           Data.Void                            (absurd)

import           Data.Functor                         (fmap)
import           Data.Functor.Identity                (Identity (..))

import           Waargonaut.Types                     (JObject, Json, WS, _JObj)


-- |
-- Define an "encoder" as a function from some @a@ to some 'Json' with the
-- allowance for some context @f@.
--
-- The helper functions 'jsonEncoder' and 'objEncoder' are probably what you
-- want to use.
--
data EncoderFns i f a = EncoderFns
  { EncoderFns i f a -> i -> Json
finaliseEncoding :: i -> Json -- ^ The @i@ need not be the final 'Json' structure. This function will complete the output from 'initialEncoding' to the final 'Json' output.

  , EncoderFns i f a -> a -> f i
initialEncoding  :: a -> f i -- ^ Run the initial encoding step of the given input. This lets you encode the @a@ to an intermediate structure before utilising the 'finaliseEncoding' function to complete the process.
  }

instance MFunctor (EncoderFns i) where
  hoist :: (forall a. m a -> n a) -> EncoderFns i m b -> EncoderFns i n b
hoist forall a. m a -> n a
nat (EncoderFns i -> Json
f b -> m i
i) = (i -> Json) -> (b -> n i) -> EncoderFns i n b
forall i (f :: * -> *) a.
(i -> Json) -> (a -> f i) -> EncoderFns i f a
EncoderFns i -> Json
f (m i -> n i
forall a. m a -> n a
nat (m i -> n i) -> (b -> m i) -> b -> n i
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> m i
i)

-- | Generalise any 'Encoder' a' to 'Encoder f a'
generaliseEncoder :: Monad f => EncoderFns i Identity a -> EncoderFns i f a
generaliseEncoder :: EncoderFns i Identity a -> EncoderFns i f a
generaliseEncoder (EncoderFns i -> Json
f a -> Identity i
i) = (i -> Json) -> (a -> f i) -> EncoderFns i f a
forall i (f :: * -> *) a.
(i -> Json) -> (a -> f i) -> EncoderFns i f a
EncoderFns i -> Json
f (Identity i -> f i
forall (m :: * -> *) a. Monad m => Identity a -> m a
generalize (Identity i -> f i) -> (a -> Identity i) -> a -> f i
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Identity i
i)

instance Contravariant (EncoderFns o f) where
  contramap :: (a -> b) -> EncoderFns o f b -> EncoderFns o f a
contramap a -> b
f EncoderFns o f b
e = (o -> Json) -> (a -> f o) -> EncoderFns o f a
forall i (f :: * -> *) a.
(i -> Json) -> (a -> f i) -> EncoderFns i f a
EncoderFns (EncoderFns o f b -> o -> Json
forall i (f :: * -> *) a. EncoderFns i f a -> i -> Json
finaliseEncoding EncoderFns o f b
e) (EncoderFns o f b -> b -> f o
forall i (f :: * -> *) a. EncoderFns i f a -> a -> f i
initialEncoding EncoderFns o f b
e (b -> f o) -> (a -> b) -> a -> f o
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)
  {-# INLINE contramap #-}

instance Applicative f => Divisible (EncoderFns (JObject WS Json) f) where
  conquer :: EncoderFns (JObject WS Json) f a
conquer = (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a (f :: * -> *).
(a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder (f (JObject WS Json) -> a -> f (JObject WS Json)
forall a b. a -> b -> a
const (JObject WS Json -> f (JObject WS Json)
forall (f :: * -> *) a. Applicative f => a -> f a
pure JObject WS Json
forall a. Monoid a => a
mempty))
  {-# INLINE conquer #-}

  divide :: (a -> (b, c))
-> EncoderFns (JObject WS Json) f b
-> EncoderFns (JObject WS Json) f c
-> EncoderFns (JObject WS Json) f a
divide a -> (b, c)
atobc (EncoderFns JObject WS Json -> Json
_ b -> f (JObject WS Json)
oB) (EncoderFns JObject WS Json -> Json
_ c -> f (JObject WS Json)
oC) = (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a (f :: * -> *).
(a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder ((a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a)
-> (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a b. (a -> b) -> a -> b
$ \a
a ->
    let
      (b
b,c
c) = a -> (b, c)
atobc a
a
    in
      (JObject WS Json -> JObject WS Json -> JObject WS Json)
-> f (JObject WS Json)
-> f (JObject WS Json)
-> f (JObject WS Json)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 JObject WS Json -> JObject WS Json -> JObject WS Json
forall a. Semigroup a => a -> a -> a
(<>) (b -> f (JObject WS Json)
oB b
b) (c -> f (JObject WS Json)
oC c
c)
  {-# INLINE divide #-}

instance Applicative f => Decidable (EncoderFns (JObject WS Json) f) where
  lose :: (a -> Void) -> EncoderFns (JObject WS Json) f a
lose a -> Void
f = (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a (f :: * -> *).
(a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder ((a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a)
-> (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a b. (a -> b) -> a -> b
$ \a
a -> Void -> f (JObject WS Json)
forall a. Void -> a
absurd (a -> Void
f a
a)
  {-# INLINE lose #-}

  choose :: (a -> Either b c)
-> EncoderFns (JObject WS Json) f b
-> EncoderFns (JObject WS Json) f c
-> EncoderFns (JObject WS Json) f a
choose a -> Either b c
split (EncoderFns JObject WS Json -> Json
_ b -> f (JObject WS Json)
oB) (EncoderFns JObject WS Json -> Json
_ c -> f (JObject WS Json)
oC) = (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a (f :: * -> *).
(a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder ((a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a)
-> (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall a b. (a -> b) -> a -> b
$ \a
a ->
    (b -> f (JObject WS Json))
-> (c -> f (JObject WS Json)) -> Either b c -> f (JObject WS Json)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> f (JObject WS Json)
oB c -> f (JObject WS Json)
oC (a -> Either b c
split a
a)
  {-# INLINE choose #-}

-- | As a convenience, this type defines the @i@ to be a specific 'Json' structure:
type Encoder f a = EncoderFns Json f a

-- | As a convenience, this type defines the @i@ to be a specific 'JObject WS Json' structure:
type ObjEncoder f a = EncoderFns (JObject WS Json) f a

-- | As a convenience, this type is a pure Encoder over 'Identity' in place of the @f@.
type Encoder' a = EncoderFns Json Identity a
-- | As a convenience, this type is a pure ObjEncoder over 'Identity' in place of the @f@.
type ObjEncoder' a = EncoderFns (JObject WS Json) Identity a

-- | Run any encoder to the 'Json' representation, allowing for some
-- 'Functor' context @f@.
runEncoder :: Functor f => EncoderFns i f a -> a -> f Json
runEncoder :: EncoderFns i f a -> a -> f Json
runEncoder EncoderFns i f a
e = (i -> Json) -> f i -> f Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EncoderFns i f a -> i -> Json
forall i (f :: * -> *) a. EncoderFns i f a -> i -> Json
finaliseEncoding EncoderFns i f a
e) (f i -> f Json) -> (a -> f i) -> a -> f Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EncoderFns i f a -> a -> f i
forall i (f :: * -> *) a. EncoderFns i f a -> a -> f i
initialEncoding EncoderFns i f a
e
{-# INLINE runEncoder #-}

-- | Run any encoder to the 'Json' representation, with the context specialised
-- to 'Identity' for convenience.
runPureEncoder :: EncoderFns i Identity a -> a -> Json
runPureEncoder :: EncoderFns i Identity a -> a -> Json
runPureEncoder EncoderFns i Identity a
e = Identity Json -> Json
forall a. Identity a -> a
runIdentity (Identity Json -> Json) -> (a -> Identity Json) -> a -> Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (i -> Json) -> Identity i -> Identity Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EncoderFns i Identity a -> i -> Json
forall i (f :: * -> *) a. EncoderFns i f a -> i -> Json
finaliseEncoding EncoderFns i Identity a
e) (Identity i -> Identity Json)
-> (a -> Identity i) -> a -> Identity Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EncoderFns i Identity a -> a -> Identity i
forall i (f :: * -> *) a. EncoderFns i f a -> a -> f i
initialEncoding EncoderFns i Identity a
e
{-# INLINE runPureEncoder #-}

-- | Helper function for creating an 'Encoder', provides the default
-- 'finaliseEncoding' function for 'Json' encoders.
jsonEncoder :: (a -> f Json) -> EncoderFns Json f a
jsonEncoder :: (a -> f Json) -> EncoderFns Json f a
jsonEncoder = (Json -> Json) -> (a -> f Json) -> EncoderFns Json f a
forall i (f :: * -> *) a.
(i -> Json) -> (a -> f i) -> EncoderFns i f a
EncoderFns Json -> Json
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE jsonEncoder #-}

-- | Helper function for creating a JSON @object@ 'Encoder'. Provides the
-- default 'finaliseEncoding' function for completing the 'JObject' to the
-- necessary 'Json' type.
objEncoder :: (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder :: (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
objEncoder = (JObject WS Json -> Json)
-> (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
forall i (f :: * -> *) a.
(i -> Json) -> (a -> f i) -> EncoderFns i f a
EncoderFns (\JObject WS Json
o -> Tagged (JObject WS Json, WS) (Identity (JObject WS Json, WS))
-> Tagged Json (Identity Json)
forall r ws a. AsJType r ws a => Prism' r (JObject ws a, ws)
_JObj (Tagged (JObject WS Json, WS) (Identity (JObject WS Json, WS))
 -> Tagged Json (Identity Json))
-> (JObject WS Json, WS) -> Json
forall t b. AReview t b -> b -> t
# (JObject WS Json
o, WS
forall a. Monoid a => a
mempty))
{-# INLINE objEncoder #-}