{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Aeson.Commit
( commit
, runCommit
, (.:>)
, tryParser
, liftParser
, Commit (..)
) where
import Control.Applicative (Alternative (..))
import Control.Monad.Except
import Data.Aeson.Types
import Data.Text (Text)
import Data.Void (Void, absurd)
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)
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
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])
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
pParser Void -> [Parser Void] -> [Parser Void]
forall a. a -> [a] -> [a]
:[Parser Void]
ps) [] [])
where
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
msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)
(.:>) :: FromJSON a => Object -> Text -> (a -> Parser b) -> Commit b
(Object
o .:> :: Object -> Text -> (a -> Parser b) -> Commit b
.:> Text
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 -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
k) (\a
v -> a -> Parser b
cont a
v Parser b -> JSONPathElement -> Parser b
forall a. Parser a -> JSONPathElement -> Parser a
<?> Text -> JSONPathElement
Key Text
k)
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
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)