{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
module Composite.Aeson.Refined (refinedJsonFormat) where

import Composite.Aeson (DefaultJsonFormat, defaultJsonFormat, JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import Control.Monad.Error.Class (throwError)
import qualified Data.Aeson.BetterErrors as ABE
import Refined
  ( Predicate, Refined, refine, unrefine
#if MIN_VERSION_refined(0,2,0)
  , displayRefineException
#endif
  )

-- |Given a @'JsonFormat' e a@, produce a @JsonFormat e ('Refined' p a)@ where @p@ is some 'Predicate' from the refined library for @a@.
--
-- This maps to the same JSON as the given 'JsonFormat', but when parsing it will apply 'refine' to assert that the incoming JSON value conforms to the
-- predicate, failing to parse if not.
refinedJsonFormat :: Predicate p a => JsonFormat e a -> JsonFormat e (Refined p a)
refinedJsonFormat :: JsonFormat e a -> JsonFormat e (Refined p a)
refinedJsonFormat (JsonFormat (JsonProfunctor a -> Value
oa Parse e a
ia)) = JsonProfunctor e (Refined p a) (Refined p a)
-> JsonFormat e (Refined p a)
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat (JsonProfunctor e (Refined p a) (Refined p a)
 -> JsonFormat e (Refined p a))
-> JsonProfunctor e (Refined p a) (Refined p a)
-> JsonFormat e (Refined p a)
forall a b. (a -> b) -> a -> b
$ (Refined p a -> Value)
-> Parse e (Refined p a)
-> JsonProfunctor e (Refined p a) (Refined p a)
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor Refined p a -> Value
o Parse e (Refined p a)
i
  where
    o :: Refined p a -> Value
o = a -> Value
oa (a -> Value) -> (Refined p a -> a) -> Refined p a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined p a -> a
forall p x. Refined p x -> x
unrefine
#if MIN_VERSION_refined(0,2,0)
    i :: Parse e (Refined p a)
i = (RefineException -> Parse e (Refined p a))
-> (Refined p a -> Parse e (Refined p a))
-> Either RefineException (Refined p a)
-> Parse e (Refined p a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parse e (Refined p a)
forall a. String -> ParseT e Identity a
toss (String -> Parse e (Refined p a))
-> (RefineException -> String)
-> RefineException
-> Parse e (Refined p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show (String -> String)
-> (RefineException -> String) -> RefineException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefineException -> String
displayRefineException) Refined p a -> Parse e (Refined p a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RefineException (Refined p a) -> Parse e (Refined p a))
-> (a -> Either RefineException (Refined p a))
-> a
-> Parse e (Refined p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either RefineException (Refined p a)
forall p x.
Predicate p x =>
x -> Either RefineException (Refined p x)
refine (a -> Parse e (Refined p a)) -> Parse e a -> Parse e (Refined p a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parse e a
ia
#else
    i = either toss pure . refine =<< ia
#endif
    toss :: String -> ParseT e Identity a
toss = ParseError e -> ParseT e Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> ParseT e Identity a)
-> (String -> ParseError e) -> String -> ParseT e Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathPiece] -> ErrorSpecifics e -> ParseError e
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] (ErrorSpecifics e -> ParseError e)
-> (String -> ErrorSpecifics e) -> String -> ParseError e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorSpecifics e
forall err. String -> ErrorSpecifics err
ABE.FromAeson

instance (DefaultJsonFormat a, Predicate p a) => DefaultJsonFormat (Refined p a) where
  defaultJsonFormat :: JsonFormat e (Refined p a)
defaultJsonFormat = JsonFormat e a -> JsonFormat e (Refined p a)
forall p a e.
Predicate p a =>
JsonFormat e a -> JsonFormat e (Refined p a)
refinedJsonFormat JsonFormat e a
forall a e. DefaultJsonFormat a => JsonFormat e a
defaultJsonFormat