{-# LANGUAGE DeriveFunctor #-}

-- |
-- Copyright: © 2022 IOHK
-- License: Apache-2.0
--
-- This module provides a utility function 'variants' for parsing
-- JSON values using one out of many parsers.
module Cardano.Wallet.Api.Aeson.Variant
    ( variants
    , Variant
    , variant
    ) where

import Prelude

import Data.Aeson.Types
    ( Object, Parser, Value, modifyFailure, withObject )

-- | Specification of a JSON parser suitable for 'variants'.
data Variant a = Variant
    { Variant a -> String
_errContext :: String
    , Variant a -> Object -> Bool
_acceptance :: Object -> Bool
    , Variant a -> Value -> Parser a
_parser :: Value -> Parser a
    }
    deriving (a -> Variant b -> Variant a
(a -> b) -> Variant a -> Variant b
(forall a b. (a -> b) -> Variant a -> Variant b)
-> (forall a b. a -> Variant b -> Variant a) -> Functor Variant
forall a b. a -> Variant b -> Variant a
forall a b. (a -> b) -> Variant a -> Variant b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Variant b -> Variant a
$c<$ :: forall a b. a -> Variant b -> Variant a
fmap :: (a -> b) -> Variant a -> Variant b
$cfmap :: forall a b. (a -> b) -> Variant a -> Variant b
Functor)

-- | Define a 'Variant' for parsing a JSON value.
--
-- A predicate checks whether a given 'Value' belongs to this variant;
-- the 'Value' is parsed only if this this check succeeds.
variant
    :: String -- ^ Error message suffix in case of parse failure.
    -> (Object -> Bool) -- ^ Check whether this variant applies.
    -> (Value -> Parser a) -- ^ Parser for this variant.
    -> Variant a
variant :: String -> (Object -> Bool) -> (Value -> Parser a) -> Variant a
variant = String -> (Object -> Bool) -> (Value -> Parser a) -> Variant a
forall a.
String -> (Object -> Bool) -> (Value -> Parser a) -> Variant a
Variant

-- | Construct a parser for @a@ from parsers for its variants.
--
-- The parser succeeds iff exactly one of the predicates of the
-- variants succeeds and the parser of that variant also succeeds.
-- Using the predicate in this way improves error messages in case
-- of parse failure.
--
-- For example, 'variants' can be used to parse a JSON value
-- into a disjoint sum ('Either') without needing a tag
-- representing the 'Left'/'Right' cases.
-- Instead, the predicates of the variants can be used to disambiguate a
-- 'Value' by checking the presence of absence of certain JSON object keys.
variants
    :: String -- ^ Error message suffix in case of parse failure.
    -> [Variant a] -- ^ Possible variants.
    -> Value -- ^ Value to parse.
    -> Parser a
variants :: String -> [Variant a] -> Value -> Parser a
variants String
ctx [Variant a]
xs Value
v = String -> (Object -> Parser a) -> Value -> Parser a
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
ctx Object -> Parser a
run Value
v
  where
    run :: Object -> Parser a
run Object
obj = case [Variant a]
xs [Variant a] -> (Variant a -> [Parser a]) -> [Parser a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Variant a -> [Parser a]
forall a. Object -> Variant a -> [Parser a]
mkParser Object
obj of
        [] -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no variant selection criteria matching"
        [Parser a
p] -> Parser a
p
        [Parser a]
_ -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"multiple variant selection criteria matching"
    mkParser :: Object -> Variant a -> [Parser a]
    mkParser :: Object -> Variant a -> [Parser a]
mkParser Object
obj (Variant String
v_ctx Object -> Bool
s Value -> Parser a
p)
        | Object -> Bool
s Object
obj =
            let ctx' :: String
ctx' = String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
v_ctx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" variant"
            in Parser a -> [Parser a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser a -> [Parser a]) -> Parser a -> [Parser a]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> Parser a -> Parser a
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ctx') (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ Value -> Parser a
p Value
v
        | Bool
otherwise = []