module Composite.Aeson.Base
  ( ToJson(..), FromJson(..), JsonProfunctor(..), _JsonProfunctor, JsonFormat(..)
  , toJsonWithFormat, fromJsonWithFormat, parseJsonWithFormat, parseJsonWithFormat'
  , dimapJsonFormat, jsonFormatWithIso, wrapJsonFormat, jsonFormatWithoutCustomError, wrappedJsonFormat
  ) where

import Control.Lens (AnIso', Iso, _2, Wrapped(type Unwrapped), _Wrapped', _Wrapped, iso, over, withIso)
import Control.Lens.TH (makeWrapped)
import Control.Monad.Except (withExceptT)
import Control.Monad.Morph (hoist)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.BetterErrors as ABE
import qualified Data.Aeson.BetterErrors.Internal as ABEI
import Data.Functor.Contravariant (Contravariant, contramap)
import Data.Profunctor (Profunctor(dimap))
import Data.Text (Text)
import Data.Void (Void)

-- |Type of functions which take a value @a@ and convert it to an 'Aeson.Value'.
--
-- Wrapper around a function of type @a -> Aeson.Value@.
--
-- Doesn't currently include support for the newer Aeson Encoding machinery, but should.
newtype ToJson a = ToJson { ToJson a -> a -> Value
unToJson :: a -> Aeson.Value }

instance Contravariant ToJson where
  contramap :: (a -> b) -> ToJson b -> ToJson a
contramap a -> b
f (ToJson b -> Value
g) = (a -> Value) -> ToJson a
forall a. (a -> Value) -> ToJson a
ToJson (b -> Value
g (b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- |Type of parsers which might emit some custom error of type @e@ and produce a value of type @a@ on success.
--
-- @a@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is
-- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic.
--
-- Wrapper about an @aeson-better-errors@ 'ABE.Parse' @e@ @a@.
newtype FromJson e a = FromJson { FromJson e a -> Parse e a
unFromJson :: ABE.Parse e a }

deriving instance Functor (FromJson e)

-- |Type of profunctors which produce and consume JSON, a composition of @ToJson@ and @FromJson@.
--
-- @a@ is the type of value that can be converted to 'Aeson.Value' using this profunctor.
-- @b@ is the type of value that can be parsed from JSON using this profunctor, and @e@ is the type of custom error that can be produced when the JSON is
-- unacceptable. If your parser doesn't produce any custom errors, leave this type polymorphic.
--
-- Profunctors must have two type parameters @a@ and @b@ so this type has two, but @JsonProfunctor@s with different types aren't useful for JSON processing
-- directly. See 'JsonFormat' for a wrapper which fixes the two types.
--
-- Doesn't currently include support for the newer Aeson Encoding machinery, but should.
data JsonProfunctor e a b = JsonProfunctor (a -> Aeson.Value) (ABE.Parse e b)

instance Profunctor (JsonProfunctor e) where
  dimap :: (a -> b)
-> (c -> d) -> JsonProfunctor e b c -> JsonProfunctor e a d
dimap a -> b
f c -> d
g (JsonProfunctor b -> Value
o Parse e c
i) = (a -> Value) -> Parse e d -> JsonProfunctor e a d
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (b -> Value
o (b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (c -> d
g (c -> d) -> Parse e c -> Parse e d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse e c
i)

-- |Observe that a 'JsonProfunctor' is isomorphic to a pair with a @ToJson@ and @FromJson@.
_JsonProfunctor :: Iso (JsonProfunctor e a b) (JsonProfunctor e' a' b') (ToJson a, FromJson e b) (ToJson a', FromJson e' b')
_JsonProfunctor :: p (ToJson a, FromJson e b) (f (ToJson a', FromJson e' b'))
-> p (JsonProfunctor e a b) (f (JsonProfunctor e' a' b'))
_JsonProfunctor =
  (JsonProfunctor e a b -> (ToJson a, FromJson e b))
-> ((ToJson a', FromJson e' b') -> JsonProfunctor e' a' b')
-> Iso
     (JsonProfunctor e a b)
     (JsonProfunctor e' a' b')
     (ToJson a, FromJson e b)
     (ToJson a', FromJson e' b')
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\ (JsonProfunctor a -> Value
o Parse e b
i) -> ((a -> Value) -> ToJson a
forall a. (a -> Value) -> ToJson a
ToJson a -> Value
o, Parse e b -> FromJson e b
forall e a. Parse e a -> FromJson e a
FromJson Parse e b
i))
      (\ (ToJson a' -> Value
o, FromJson Parse e' b'
i) -> (a' -> Value) -> Parse e' b' -> JsonProfunctor e' a' b'
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor a' -> Value
o Parse e' b'
i)

-- |Wrapper around 'JsonProfunctor' for use in JSON processing when the profunctor represents a bijection between JSON and a single type @a@, i.e. for
-- @JsonProfunctor e a a@.
newtype JsonFormat e a = JsonFormat { JsonFormat e a -> JsonProfunctor e a a
unJsonFormat :: JsonProfunctor e a a }

-- |Given a 'JsonFormat' for @a@, convert a value of @a@ into an 'Aeson.Value'.
toJsonWithFormat :: JsonFormat e a -> a -> Aeson.Value
toJsonWithFormat :: JsonFormat e a -> a -> Value
toJsonWithFormat (JsonFormat (JsonProfunctor a -> Value
o Parse e a
_)) = a -> Value
o

-- |Given a 'JsonFormat' for @a@ which can produce custom errors of type @e@, yield an @aeson-better-errors@ 'ABE.Parse' which can be used to consume JSON.
fromJsonWithFormat :: JsonFormat e a -> ABE.Parse e a
fromJsonWithFormat :: JsonFormat e a -> Parse e a
fromJsonWithFormat (JsonFormat (JsonProfunctor a -> Value
_ Parse e a
i)) = Parse e a
i

-- |Given a 'JsonFormat' for @a@ which produces custom errors of type @e@ and some function to format those errors as messages, produce an Aeson parser function
-- @Value -> Parser a@.
parseJsonWithFormat :: (e -> Text) -> JsonFormat e a -> Aeson.Value -> Aeson.Parser a
parseJsonWithFormat :: (e -> Text) -> JsonFormat e a -> Value -> Parser a
parseJsonWithFormat e -> Text
showError = (e -> Text) -> Parse e a -> Value -> Parser a
forall err a. (err -> Text) -> Parse err a -> Value -> Parser a
ABE.toAesonParser e -> Text
showError (Parse e a -> Value -> Parser a)
-> (JsonFormat e a -> Parse e a)
-> JsonFormat e a
-> Value
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonFormat e a -> Parse e a
forall e a. JsonFormat e a -> Parse e a
fromJsonWithFormat

-- |Given a 'JsonFormat' for @a@ which doesn't produce custom errors, produce an Aeson parser function @Value -> Parser a@.
parseJsonWithFormat' :: JsonFormat Void a -> Aeson.Value -> Aeson.Parser a
parseJsonWithFormat' :: JsonFormat Void a -> Value -> Parser a
parseJsonWithFormat' = Parse' a -> Value -> Parser a
forall a. Parse' a -> Value -> Parser a
ABE.toAesonParser' (Parse' a -> Value -> Parser a)
-> (JsonFormat Void a -> Parse' a)
-> JsonFormat Void a
-> Value
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonFormat Void a -> Parse' a
forall e a. JsonFormat e a -> Parse e a
fromJsonWithFormat

makeWrapped ''ToJson
makeWrapped ''FromJson
makeWrapped ''JsonFormat

-- |Wrap a 'JsonFormat' for type @a@ in a pair of functions representing an isomorphism between @a@ and @b@ to produce a new @JsonFormat@ for @b@.
dimapJsonFormat :: (b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b
dimapJsonFormat :: (b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b
dimapJsonFormat b -> a
f a -> b
g = ASetter
  (JsonFormat e a)
  (JsonFormat e b)
  (JsonProfunctor e a a)
  (JsonProfunctor e b b)
-> (JsonProfunctor e a a -> JsonProfunctor e b b)
-> JsonFormat e a
-> JsonFormat e b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (JsonFormat e a)
  (JsonFormat e b)
  (JsonProfunctor e a a)
  (JsonProfunctor e b b)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((b -> a)
-> (a -> b) -> JsonProfunctor e a a -> JsonProfunctor e b b
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap b -> a
f a -> b
g)

-- |Given a @'JsonFormat' e a@ and a pair of functions @b -> a@ and @a -> Either e b@, produce a @'JsonFormat' e b@.
--
-- This is for the common case of a @newtype@ wrapper which asserts some kind of validation has been done, e.g.:
--
-- @
--   newtype MyType = MyType { unMyType :: Int }
--
--   mkMyType :: Int -> Either Text MyType
--   mkMyType i | i <= 0    = Left "must be positive!"
--              | otherwise = Right (MyType i)
--
--   myTypeJsonFormat :: JsonFormat e MyType
--   myTypeJsonFormat = wrapJsonFormat intJsonFormat mkMyType unMyType
-- @
wrapJsonFormat :: JsonFormat e a -> (a -> Either e b) -> (b -> a) -> JsonFormat e b
wrapJsonFormat :: JsonFormat e a -> (a -> Either e b) -> (b -> a) -> JsonFormat e b
wrapJsonFormat (JsonFormat (JsonProfunctor a -> Value
oa Parse e a
ia)) a -> Either e b
ab b -> a
ba = JsonProfunctor e b b -> JsonFormat e b
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat ((b -> Value) -> Parse e b -> JsonProfunctor e b b
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor b -> Value
ob Parse e b
ib)
  where
    ob :: b -> Value
ob = a -> Value
oa (a -> Value) -> (b -> a) -> b -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
ba
    ib :: Parse e b
ib = (e -> Parse e b) -> (b -> Parse e b) -> Either e b -> Parse e b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> Parse e b
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
err -> ParseT err m a
ABE.throwCustomError b -> Parse e b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e b -> Parse e b) -> (a -> Either e b) -> a -> Parse e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e b
ab (a -> Parse e b) -> Parse e a -> Parse e b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parse e a
ia

-- |Take a 'JsonFormat' which produces some 'Show'-able custom error and convert any custom errors into Aeson 'fail' style errors. Since the custom errors
-- are never generated by the resulting 'JsonFormat', any custom error type can be assumed.
--
-- This is commonly used to take a more specific @'JsonFormat' MyError MyType@ and make it a more generic @'JsonFormat' e MyType@, e.g. to be used as a 
-- 'Composite.Aeson.Default.defaultJsonFormat'.
jsonFormatWithoutCustomError :: Show e => JsonFormat e a -> JsonFormat e' a
jsonFormatWithoutCustomError :: JsonFormat e a -> JsonFormat e' a
jsonFormatWithoutCustomError =
  ASetter
  (JsonFormat e a)
  (JsonFormat e' a)
  (ParseT e Identity a)
  (ParseT e' Identity a)
-> (ParseT e Identity a -> ParseT e' Identity a)
-> JsonFormat e a
-> JsonFormat e' a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((JsonProfunctor e a a -> Identity (JsonProfunctor e' a a))
-> JsonFormat e a -> Identity (JsonFormat e' a)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((JsonProfunctor e a a -> Identity (JsonProfunctor e' a a))
 -> JsonFormat e a -> Identity (JsonFormat e' a))
-> ((ParseT e Identity a -> Identity (ParseT e' Identity a))
    -> JsonProfunctor e a a -> Identity (JsonProfunctor e' a a))
-> ASetter
     (JsonFormat e a)
     (JsonFormat e' a)
     (ParseT e Identity a)
     (ParseT e' Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ToJson a, FromJson e a) -> Identity (ToJson a, FromJson e' a))
-> JsonProfunctor e a a -> Identity (JsonProfunctor e' a a)
forall e a b e' a' b'.
Iso
  (JsonProfunctor e a b)
  (JsonProfunctor e' a' b')
  (ToJson a, FromJson e b)
  (ToJson a', FromJson e' b')
_JsonProfunctor (((ToJson a, FromJson e a) -> Identity (ToJson a, FromJson e' a))
 -> JsonProfunctor e a a -> Identity (JsonProfunctor e' a a))
-> ((ParseT e Identity a -> Identity (ParseT e' Identity a))
    -> (ToJson a, FromJson e a) -> Identity (ToJson a, FromJson e' a))
-> (ParseT e Identity a -> Identity (ParseT e' Identity a))
-> JsonProfunctor e a a
-> Identity (JsonProfunctor e' a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FromJson e a -> Identity (FromJson e' a))
-> (ToJson a, FromJson e a) -> Identity (ToJson a, FromJson e' a)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((FromJson e a -> Identity (FromJson e' a))
 -> (ToJson a, FromJson e a) -> Identity (ToJson a, FromJson e' a))
-> ((ParseT e Identity a -> Identity (ParseT e' Identity a))
    -> FromJson e a -> Identity (FromJson e' a))
-> (ParseT e Identity a -> Identity (ParseT e' Identity a))
-> (ToJson a, FromJson e a)
-> Identity (ToJson a, FromJson e' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseT e Identity a -> Identity (ParseT e' Identity a))
-> FromJson e a -> Identity (FromJson e' a)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped) ((ParseT e Identity a -> ParseT e' Identity a)
 -> JsonFormat e a -> JsonFormat e' a)
-> (ParseT e Identity a -> ParseT e' Identity a)
-> JsonFormat e a
-> JsonFormat e' a
forall a b. (a -> b) -> a -> b
$
    (ReaderT ParseReader (ExceptT (ParseError e) Identity) a
 -> ReaderT ParseReader (ExceptT (ParseError e') Identity) a)
-> ParseT e Identity a -> ParseT e' Identity a
forall err (m :: * -> *) a err' (m' :: * -> *) a'.
(ReaderT ParseReader (ExceptT (ParseError err) m) a
 -> ReaderT ParseReader (ExceptT (ParseError err') m') a')
-> ParseT err m a -> ParseT err' m' a'
ABEI.mapParseT ((ReaderT ParseReader (ExceptT (ParseError e) Identity) a
  -> ReaderT ParseReader (ExceptT (ParseError e') Identity) a)
 -> ParseT e Identity a -> ParseT e' Identity a)
-> (ReaderT ParseReader (ExceptT (ParseError e) Identity) a
    -> ReaderT ParseReader (ExceptT (ParseError e') Identity) a)
-> ParseT e Identity a
-> ParseT e' Identity a
forall a b. (a -> b) -> a -> b
$ (forall a.
 ExceptT (ParseError e) Identity a
 -> ExceptT (ParseError e') Identity a)
-> ReaderT ParseReader (ExceptT (ParseError e) Identity) a
-> ReaderT ParseReader (ExceptT (ParseError e') Identity) a
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist ((forall a.
  ExceptT (ParseError e) Identity a
  -> ExceptT (ParseError e') Identity a)
 -> ReaderT ParseReader (ExceptT (ParseError e) Identity) a
 -> ReaderT ParseReader (ExceptT (ParseError e') Identity) a)
-> (forall a.
    ExceptT (ParseError e) Identity a
    -> ExceptT (ParseError e') Identity a)
-> ReaderT ParseReader (ExceptT (ParseError e) Identity) a
-> ReaderT ParseReader (ExceptT (ParseError e') Identity) a
forall a b. (a -> b) -> a -> b
$ (ParseError e -> ParseError e')
-> ExceptT (ParseError e) Identity a
-> ExceptT (ParseError e') Identity a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ((ParseError e -> ParseError e')
 -> ExceptT (ParseError e) Identity a
 -> ExceptT (ParseError e') Identity a)
-> (ParseError e -> ParseError e')
-> ExceptT (ParseError e) Identity a
-> ExceptT (ParseError e') Identity a
forall a b. (a -> b) -> a -> b
$ \ case
        ABEI.BadSchema [PathPiece]
pos (ABEI.KeyMissing Text
k)       -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (Text -> ErrorSpecifics e'
forall err. Text -> ErrorSpecifics err
ABEI.KeyMissing Text
k)
        ABEI.BadSchema [PathPiece]
pos (ABEI.OutOfBounds Int
i)      -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (Int -> ErrorSpecifics e'
forall err. Int -> ErrorSpecifics err
ABEI.OutOfBounds Int
i)
        ABEI.BadSchema [PathPiece]
pos (ABEI.WrongType JSONType
t Value
v)      -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (JSONType -> Value -> ErrorSpecifics e'
forall err. JSONType -> Value -> ErrorSpecifics err
ABEI.WrongType JSONType
t Value
v)
        ABEI.BadSchema [PathPiece]
pos (ABEI.ExpectedIntegral Double
d) -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (Double -> ErrorSpecifics e'
forall err. Double -> ErrorSpecifics err
ABEI.ExpectedIntegral Double
d)
        ABEI.BadSchema [PathPiece]
pos (ABEI.FromAeson String
e)        -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (String -> ErrorSpecifics e'
forall err. String -> ErrorSpecifics err
ABEI.FromAeson String
e)
        ABEI.BadSchema [PathPiece]
pos (ABEI.CustomError e
e)      -> [PathPiece] -> ErrorSpecifics e' -> ParseError e'
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABEI.BadSchema [PathPiece]
pos (String -> ErrorSpecifics e'
forall err. String -> ErrorSpecifics err
ABEI.FromAeson (e -> String
forall a. Show a => a -> String
show e
e))

        ABEI.InvalidJSON String
msg -> String -> ParseError e'
forall err. String -> ParseError err
ABEI.InvalidJSON String
msg

-- |Wrap a 'JsonFormat' for type @a@ in an isomorphism to produce a new @JsonFormat@ for @b@.
jsonFormatWithIso :: AnIso' b a -> JsonFormat e a -> JsonFormat e b
jsonFormatWithIso :: AnIso' b a -> JsonFormat e a -> JsonFormat e b
jsonFormatWithIso AnIso' b a
i = AnIso' b a
-> ((b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b)
-> JsonFormat e a
-> JsonFormat e b
forall s t a b r. AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso AnIso' b a
i (b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b
forall b a e.
(b -> a) -> (a -> b) -> JsonFormat e a -> JsonFormat e b
dimapJsonFormat

-- |Given a format for the value type inside some wrapper type @a@ which instances 'Wrapped', produce a format which works on the wrapper type.
wrappedJsonFormat :: Wrapped a => JsonFormat e (Unwrapped a) -> JsonFormat e a
wrappedJsonFormat :: JsonFormat e (Unwrapped a) -> JsonFormat e a
wrappedJsonFormat = AnIso' a (Unwrapped a)
-> JsonFormat e (Unwrapped a) -> JsonFormat e a
forall b a e. AnIso' b a -> JsonFormat e a -> JsonFormat e b
jsonFormatWithIso AnIso' a (Unwrapped a)
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'