{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
--   Commit mechanism for aeson's 'Parser'.
--   To commit means that if some initial parsing succeeds, subsequent failures are unrecoverable.
--
--   In the following example, we use '.:>' to look for a key @.nested.value@, and if that does not exist, @.value@.
--
--   > parse o = (o .:> "nested") (withObject "nestedObj" (.: "value"))
--   >         <|> tryParser (o .: "value")
--
--   Not having the key @nested@ is a normal, recoverable failure, and parsing will continue looking for @value@.
--   However, if @nested@ is present but malformed, parsing fails.
--
--   > { value: "foo", otherField: "bar" }
--   > -> Right "foo"
--   >
--   > { value: "foo", nested: { value: "bar" } }
--   > -> Right "bar"
--   >
--   > { value: "foo", nested: { bar: 9 } }
--   > -> Left "Error in $.nested: key \"value\" not found"
--   >
--   > { value: "foo", nested: 9 }
--   > -> Left "Error in $.nested: parsing nestedObj failed, expected Object, but encountered Number"
--   >
--   > {}
--   > -> Left
--   >   "Error in $: No match,
--   >    - key \"value\" not found"
--   >    - key \"nested\" not found"
module Data.Aeson.Commit
  ( commit,
    runCommit,
    (.:>),
    tryParser,
    liftParser,
    Commit (..),
  )
where

import Control.Applicative (Alternative (..))
import Control.Monad.Except
import Data.Aeson.Types
import Data.Void (Void, absurd)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Key
#else
import Data.Text (Text)
#endif

-- | A 'Commit' is a 'Parser' that has two failure modes; recoverable and non-recoverable.
--
--   > tryParser empty <|> p = p
--   > liftParser empty <|> p = empty
--
--   'Commit' is typically constructed using 'commit', and consumed using 'runCommit', which captures its result in a 'Parser'.
--
--   The implementation works by wrapping 'Parser' in an 'ExceptT'.
--   The derived 'Alternative' instance will then only recover from failures in the 'ExceptT'.
--   This means that as soon as we successfully construct a 'Right' value, the 'Alternative' considers the 'Commit' a success, even though the underlying parser might have failed.
--   The 'Void' represents the guarantee that we only collect error values.
newtype Commit a = Commit {Commit a -> ExceptT [Parser Void] Parser a
unCommit :: ExceptT [Parser Void] Parser a}
  deriving (Applicative Commit
a -> Commit a
Applicative Commit
-> (forall a b. Commit a -> (a -> Commit b) -> Commit b)
-> (forall a b. Commit a -> Commit b -> Commit b)
-> (forall a. a -> Commit a)
-> Monad Commit
Commit a -> (a -> Commit b) -> Commit b
Commit a -> Commit b -> Commit b
forall a. a -> Commit a
forall a b. Commit a -> Commit b -> Commit b
forall a b. Commit a -> (a -> Commit b) -> Commit b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Commit a
$creturn :: forall a. a -> Commit a
>> :: Commit a -> Commit b -> Commit b
$c>> :: forall a b. Commit a -> Commit b -> Commit b
>>= :: Commit a -> (a -> Commit b) -> Commit b
$c>>= :: forall a b. Commit a -> (a -> Commit b) -> Commit b
$cp1Monad :: Applicative Commit
Monad, a -> Commit b -> Commit a
(a -> b) -> Commit a -> Commit b
(forall a b. (a -> b) -> Commit a -> Commit b)
-> (forall a b. a -> Commit b -> Commit a) -> Functor Commit
forall a b. a -> Commit b -> Commit a
forall a b. (a -> b) -> Commit a -> Commit b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Commit b -> Commit a
$c<$ :: forall a b. a -> Commit b -> Commit a
fmap :: (a -> b) -> Commit a -> Commit b
$cfmap :: forall a b. (a -> b) -> Commit a -> Commit b
Functor, Functor Commit
a -> Commit a
Functor Commit
-> (forall a. a -> Commit a)
-> (forall a b. Commit (a -> b) -> Commit a -> Commit b)
-> (forall a b c.
    (a -> b -> c) -> Commit a -> Commit b -> Commit c)
-> (forall a b. Commit a -> Commit b -> Commit b)
-> (forall a b. Commit a -> Commit b -> Commit a)
-> Applicative Commit
Commit a -> Commit b -> Commit b
Commit a -> Commit b -> Commit a
Commit (a -> b) -> Commit a -> Commit b
(a -> b -> c) -> Commit a -> Commit b -> Commit c
forall a. a -> Commit a
forall a b. Commit a -> Commit b -> Commit a
forall a b. Commit a -> Commit b -> Commit b
forall a b. Commit (a -> b) -> Commit a -> Commit b
forall a b c. (a -> b -> c) -> Commit a -> Commit b -> Commit c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Commit a -> Commit b -> Commit a
$c<* :: forall a b. Commit a -> Commit b -> Commit a
*> :: Commit a -> Commit b -> Commit b
$c*> :: forall a b. Commit a -> Commit b -> Commit b
liftA2 :: (a -> b -> c) -> Commit a -> Commit b -> Commit c
$cliftA2 :: forall a b c. (a -> b -> c) -> Commit a -> Commit b -> Commit c
<*> :: Commit (a -> b) -> Commit a -> Commit b
$c<*> :: forall a b. Commit (a -> b) -> Commit a -> Commit b
pure :: a -> Commit a
$cpure :: forall a. a -> Commit a
$cp1Applicative :: Functor Commit
Applicative, Applicative Commit
Commit a
Applicative Commit
-> (forall a. Commit a)
-> (forall a. Commit a -> Commit a -> Commit a)
-> (forall a. Commit a -> Commit [a])
-> (forall a. Commit a -> Commit [a])
-> Alternative Commit
Commit a -> Commit a -> Commit a
Commit a -> Commit [a]
Commit a -> Commit [a]
forall a. Commit a
forall a. Commit a -> Commit [a]
forall a. Commit a -> Commit a -> Commit a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Commit a -> Commit [a]
$cmany :: forall a. Commit a -> Commit [a]
some :: Commit a -> Commit [a]
$csome :: forall a. Commit a -> Commit [a]
<|> :: Commit a -> Commit a -> Commit a
$c<|> :: forall a. Commit a -> Commit a -> Commit a
empty :: Commit a
$cempty :: forall a. Commit a
$cp1Alternative :: Applicative Commit
Alternative)

-- | Construct a commit.
--   If the first parser fails, the failure is recoverable through 'Alternative'.
--   If the first parser succeeds, the 'Commit' is a success, and any failures in the inner action will be preserved.
commit :: Parser a -> (a -> Parser b) -> Commit b
commit :: Parser a -> (a -> Parser b) -> Commit b
commit Parser a
pre a -> Parser b
post = ExceptT [Parser Void] Parser b -> Commit b
forall a. ExceptT [Parser Void] Parser a -> Commit a
Commit (ExceptT [Parser Void] Parser b -> Commit b)
-> ExceptT [Parser Void] Parser b -> Commit b
forall a b. (a -> b) -> a -> b
$ do
  a
a <- Parser (Either [Parser Void] a) -> ExceptT [Parser Void] Parser a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Parser (Either [Parser Void] a) -> ExceptT [Parser Void] Parser a)
-> Parser (Either [Parser Void] a)
-> ExceptT [Parser Void] Parser a
forall a b. (a -> b) -> a -> b
$ Parser a -> Parser (Either [Parser Void] a)
forall b. Parser b -> Parser (Either [Parser Void] b)
captureError Parser a
pre
  Parser b -> ExceptT [Parser Void] Parser b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser b -> ExceptT [Parser Void] Parser b)
-> Parser b -> ExceptT [Parser Void] Parser b
forall a b. (a -> b) -> a -> b
$ a -> Parser b
post a
a
  where
    -- TODO maybe there's a better way to prove something is an error
    captureError :: Parser b -> Parser (Either [Parser Void] b)
    captureError :: Parser b -> Parser (Either [Parser Void] b)
captureError Parser b
p = b -> Either [Parser Void] b
forall a b. b -> Either a b
Right (b -> Either [Parser Void] b)
-> Parser b -> Parser (Either [Parser Void] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
p Parser (Either [Parser Void] b)
-> Parser (Either [Parser Void] b)
-> Parser (Either [Parser Void] b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either [Parser Void] b -> Parser (Either [Parser Void] b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Parser Void] -> Either [Parser Void] b
forall a b. a -> Either a b
Left [(b -> Void) -> Parser b -> Parser Void
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Void -> b -> Void
forall a b. a -> b -> a
const Void
forall a. HasCallStack => a
undefined) Parser b
p])

-- | Run a 'Commit', capturing its result in a 'Parser'.
runCommit :: Commit a -> Parser a
runCommit :: Commit a -> Parser a
runCommit (Commit ExceptT [Parser Void] Parser a
f) = ExceptT [Parser Void] Parser a -> Parser (Either [Parser Void] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT [Parser Void] Parser a
f Parser (Either [Parser Void] a)
-> (Either [Parser Void] a -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Parser Void] -> Parser a)
-> (a -> Parser a) -> Either [Parser Void] a -> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Parser Void] -> Parser a
forall a. [Parser Void] -> Parser a
handleErrors a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    handleErrors :: [Parser Void] -> Parser a
    handleErrors :: [Parser Void] -> Parser a
handleErrors [] = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No parsers tried"
    handleErrors (Parser Void
p : [Parser Void]
ps) = (Void -> a) -> Parser Void -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> a
forall a. Void -> a
absurd ([Parser Void] -> JSONPath -> [String] -> Parser Void
forall a. [Parser a] -> JSONPath -> [String] -> Parser a
go (Parser Void
p Parser Void -> [Parser Void] -> [Parser Void]
forall a. a -> [a] -> [a]
: [Parser Void]
ps) [] [])
      where
        -- TODO: how do we handle the multiple JSONPaths?
        -- Right now the rightmost failure's path is used when presenting
        -- the error message. Ideally one path per error would be preferable but
        -- `aeson` doesn't support such a thing. When errors are reported in `aeson`
        -- a single JSONPath defines how the error message is presented.
        go :: [Parser a] -> JSONPath -> [String] -> Parser a
go [] JSONPath
path [String]
errors = JSONPath -> String -> Parser a
forall a. JSONPath -> String -> Parser a
parserThrowError JSONPath
path (String
"No match,\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) [String]
errors))
        go (Parser a
y : [Parser a]
ys) JSONPath
_ [String]
msgs = Parser a -> (JSONPath -> String -> Parser a) -> Parser a
forall a. Parser a -> (JSONPath -> String -> Parser a) -> Parser a
parserCatchError Parser a
y ((JSONPath -> String -> Parser a) -> Parser a)
-> (JSONPath -> String -> Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \JSONPath
path String
msg ->
          [Parser a] -> JSONPath -> [String] -> Parser a
go [Parser a]
ys JSONPath
path (String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
msgs)

-- | Convenience wrapper around 'commit' for when the commit is checking whether a key is present in some object.
--   If it is, it will commit and append the key to the JSONPath of the inner context through '<?>', which will give nicer error messages.

#if MIN_VERSION_aeson(2,0,0)
(.:>)  :: FromJSON a => Object -> Key.Key -> (a -> Parser b) -> Commit b
#else
(.:>)  :: FromJSON a => Object -> Text -> (a -> Parser b) -> Commit b
#endif
(Object
o .:> :: Object -> Key -> (a -> Parser b) -> Commit b
.:> Key
k) a -> Parser b
cont = Parser a -> (a -> Parser b) -> Commit b
forall a b. Parser a -> (a -> Parser b) -> Commit b
commit (Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
k) (\a
v -> a -> Parser b
cont a
v Parser b -> JSONPathElement -> Parser b
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k)

-- | Turn a 'Parser' into a 'Commit'
--   Unlike 'liftParser', the parser's failure is recoverable.
--
-- > tryParser empty <|> p = p
-- > tryParser p = commit p pure
tryParser :: Parser a -> Commit a
tryParser :: Parser a -> Commit a
tryParser Parser a
p = Parser a -> (a -> Parser a) -> Commit a
forall a b. Parser a -> (a -> Parser b) -> Commit b
commit Parser a
p a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Turn a 'Parser' into a 'Commit'.
--   Unlike 'tryParser', the parser's failure is _not_ recoverable, i.e. the parse is always committed.
--
-- > liftParser empty <|> p = empty
-- > liftParser p = commit (pure ()) (const p)
liftParser :: Parser a -> Commit a
liftParser :: Parser a -> Commit a
liftParser Parser a
p = Parser () -> (() -> Parser a) -> Commit a
forall a b. Parser a -> (a -> Parser b) -> Commit b
commit (() -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Parser a -> () -> Parser a
forall a b. a -> b -> a
const Parser a
p)