{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Data.Aeson.Config.Parser (
  Parser
, runParser

, typeMismatch
, withObject
, withText
, withString
, withArray
, withNumber
, withBool

, explicitParseField
, explicitParseFieldMaybe

, Aeson.JSONPathElement(..)
, (<?>)

, Value(..)
, Object
, Array

, liftParser

, fromAesonPath
, formatPath

, markDeprecated
) where

import           Imports

import qualified Control.Monad.Fail as Fail
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Writer
import           Data.Scientific
import           Data.Set (Set, notMember)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector as V
import           Data.Aeson.Config.Key (Key)
import qualified Data.Aeson.Config.Key as Key
import qualified Data.Aeson.Config.KeyMap as KeyMap
import           Data.Aeson.Types (Value(..), Object, Array)
import qualified Data.Aeson.Types as Aeson
#if MIN_VERSION_aeson(2,1,0)
import           Data.Aeson.Types (IResult(..), iparse)
#else
import           Data.Aeson.Internal (IResult(..), iparse)
#endif
#if !MIN_VERSION_aeson(1,4,5)
import qualified Data.Aeson.Internal as Aeson
#endif

-- This is needed so that we have an Ord instance for aeson < 1.2.4.
data JSONPathElement = Key Text | Index Int
  deriving (JSONPathElement -> JSONPathElement -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONPathElement -> JSONPathElement -> Bool
$c/= :: JSONPathElement -> JSONPathElement -> Bool
== :: JSONPathElement -> JSONPathElement -> Bool
$c== :: JSONPathElement -> JSONPathElement -> Bool
Eq, Int -> JSONPathElement -> ShowS
JSONPath -> ShowS
JSONPathElement -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: JSONPath -> ShowS
$cshowList :: JSONPath -> ShowS
show :: JSONPathElement -> [Char]
$cshow :: JSONPathElement -> [Char]
showsPrec :: Int -> JSONPathElement -> ShowS
$cshowsPrec :: Int -> JSONPathElement -> ShowS
Show, Eq JSONPathElement
JSONPathElement -> JSONPathElement -> Bool
JSONPathElement -> JSONPathElement -> Ordering
JSONPathElement -> JSONPathElement -> JSONPathElement
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: JSONPathElement -> JSONPathElement -> JSONPathElement
$cmin :: JSONPathElement -> JSONPathElement -> JSONPathElement
max :: JSONPathElement -> JSONPathElement -> JSONPathElement
$cmax :: JSONPathElement -> JSONPathElement -> JSONPathElement
>= :: JSONPathElement -> JSONPathElement -> Bool
$c>= :: JSONPathElement -> JSONPathElement -> Bool
> :: JSONPathElement -> JSONPathElement -> Bool
$c> :: JSONPathElement -> JSONPathElement -> Bool
<= :: JSONPathElement -> JSONPathElement -> Bool
$c<= :: JSONPathElement -> JSONPathElement -> Bool
< :: JSONPathElement -> JSONPathElement -> Bool
$c< :: JSONPathElement -> JSONPathElement -> Bool
compare :: JSONPathElement -> JSONPathElement -> Ordering
$ccompare :: JSONPathElement -> JSONPathElement -> Ordering
Ord)

type JSONPath = [JSONPathElement]

data Path = Consumed JSONPath | Deprecated JSONPath JSONPath
  deriving (Path -> Path -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Eq Path
Path -> Path -> Bool
Path -> Path -> Ordering
Path -> Path -> Path
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Path -> Path -> Path
$cmin :: Path -> Path -> Path
max :: Path -> Path -> Path
$cmax :: Path -> Path -> Path
>= :: Path -> Path -> Bool
$c>= :: Path -> Path -> Bool
> :: Path -> Path -> Bool
$c> :: Path -> Path -> Bool
<= :: Path -> Path -> Bool
$c<= :: Path -> Path -> Bool
< :: Path -> Path -> Bool
$c< :: Path -> Path -> Bool
compare :: Path -> Path -> Ordering
$ccompare :: Path -> Path -> Ordering
Ord, Int -> Path -> ShowS
[Path] -> ShowS
Path -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> [Char]
$cshow :: Path -> [Char]
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)

fromAesonPath :: Aeson.JSONPath -> JSONPath
fromAesonPath :: JSONPath -> JSONPath
fromAesonPath = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map JSONPathElement -> JSONPathElement
fromAesonPathElement

fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement
fromAesonPathElement :: JSONPathElement -> JSONPathElement
fromAesonPathElement JSONPathElement
e = case JSONPathElement
e of
  Aeson.Key Key
k -> Text -> JSONPathElement
Key (Key -> Text
Key.toText Key
k)
  Aeson.Index Int
n -> Int -> JSONPathElement
Index Int
n

newtype Parser a = Parser {forall a. Parser a -> WriterT (Set Path) Parser a
unParser :: WriterT (Set Path) Aeson.Parser a}
  deriving (forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor, Functor Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser 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
<* :: forall a b. Parser a -> Parser b -> Parser a
$c<* :: forall a b. Parser a -> Parser b -> Parser a
*> :: forall a b. Parser a -> Parser b -> Parser b
$c*> :: forall a b. Parser a -> Parser b -> Parser b
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
pure :: forall a. a -> Parser a
$cpure :: forall a. a -> Parser a
Applicative, Applicative Parser
forall a. Parser a
forall a. Parser a -> Parser [a]
forall a. Parser a -> Parser a -> Parser 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 :: forall a. Parser a -> Parser [a]
$cmany :: forall a. Parser a -> Parser [a]
some :: forall a. Parser a -> Parser [a]
$csome :: forall a. Parser a -> Parser [a]
<|> :: forall a. Parser a -> Parser a -> Parser a
$c<|> :: forall a. Parser a -> Parser a -> Parser a
empty :: forall a. Parser a
$cempty :: forall a. Parser a
Alternative, Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser 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 :: forall a. a -> Parser a
$creturn :: forall a. a -> Parser a
>> :: forall a b. Parser a -> Parser b -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
Monad, Monad Parser
forall a. [Char] -> Parser a
forall (m :: * -> *).
Monad m -> (forall a. [Char] -> m a) -> MonadFail m
fail :: forall a. [Char] -> Parser a
$cfail :: forall a. [Char] -> Parser a
Fail.MonadFail)

liftParser :: Aeson.Parser a -> Parser a
liftParser :: forall a. Parser a -> Parser a
liftParser = forall a. WriterT (Set Path) Parser a -> Parser a
Parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runParser :: (Value -> Parser a) -> Value -> Either String (a, [String], [(String, String)])
runParser :: forall a.
(Value -> Parser a)
-> Value -> Either [Char] (a, [[Char]], [([Char], [Char])])
runParser Value -> Parser a
p Value
v = case forall a b. (a -> Parser b) -> a -> IResult b
iparse (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> WriterT (Set Path) Parser a
unParser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
p) Value
v of
  IError JSONPath
path [Char]
err -> forall a b. a -> Either a b
Left ([Char]
"Error while parsing " forall a. [a] -> [a] -> [a]
++ JSONPath -> [Char]
formatPath (JSONPath -> JSONPath
fromAesonPath JSONPath
path) forall a. [a] -> [a] -> [a]
++ [Char]
" - " forall a. [a] -> [a] -> [a]
++ [Char]
err)
  ISuccess (a
a, Set Path
paths) -> forall a b. b -> Either a b
Right (a
a, forall a b. (a -> b) -> [a] -> [b]
map JSONPath -> [Char]
formatPath (Set Path -> Value -> [JSONPath]
determineUnconsumed Set Path
paths Value
v), [(JSONPath -> [Char]
formatPath JSONPath
name, JSONPath -> [Char]
formatPath JSONPath
substitute) | Deprecated JSONPath
name JSONPath
substitute <- forall a. Set a -> [a]
Set.toList Set Path
paths])

formatPath :: JSONPath -> String
formatPath :: JSONPath -> [Char]
formatPath = [Char] -> JSONPath -> [Char]
go [Char]
"$" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    go :: String -> JSONPath -> String
    go :: [Char] -> JSONPath -> [Char]
go [Char]
acc JSONPath
path = case JSONPath
path of
      [] -> [Char]
acc
      Index Int
n : JSONPath
xs -> [Char] -> JSONPath -> [Char]
go ([Char]
acc forall a. [a] -> [a] -> [a]
++ [Char]
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
"]") JSONPath
xs
      Key Text
key : JSONPath
xs -> [Char] -> JSONPath -> [Char]
go ([Char]
acc forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key) JSONPath
xs

determineUnconsumed :: Set Path -> Value -> [JSONPath]
determineUnconsumed :: Set Path -> Value -> [JSONPath]
determineUnconsumed ((forall a. Semigroup a => a -> a -> a
<> forall a. a -> Set a
Set.singleton (JSONPath -> Path
Consumed [])) -> Set Path
consumed) = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. Writer w a -> w
execWriter forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONPath -> Value -> Writer (Set JSONPath) ()
go []
  where
    go :: JSONPath -> Value -> Writer (Set JSONPath) ()
    go :: JSONPath -> Value -> Writer (Set JSONPath) ()
go JSONPath
path Value
value
      | JSONPath -> Path
Consumed JSONPath
path forall a. Ord a => a -> Set a -> Bool
`notMember` Set Path
consumed = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. a -> Set a
Set.singleton JSONPath
path)
      | Bool
otherwise = case Value
value of
          Number Scientific
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          String Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Bool Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Value
Null -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Object Object
o -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o) forall a b. (a -> b) -> a -> b
$ \ (Key -> Text
Key.toText -> Text
k, Value
v) -> do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
"_" Text -> Text -> Bool
`T.isPrefixOf` Text
k) forall a b. (a -> b) -> a -> b
$ do
                JSONPath -> Value -> Writer (Set JSONPath) ()
go (Text -> JSONPathElement
Key Text
k forall a. a -> [a] -> [a]
: JSONPath
path) Value
v
          Array Array
xs -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Array
xs) forall a b. (a -> b) -> a -> b
$ \ (Int
n, Value
v) -> do
              JSONPath -> Value -> Writer (Set JSONPath) ()
go (Int -> JSONPathElement
Index Int
n forall a. a -> [a] -> [a]
: JSONPath
path) Value
v

(<?>) :: Parser a -> Aeson.JSONPathElement -> Parser a
<?> :: forall a. Parser a -> JSONPathElement -> Parser a
(<?>) (Parser (WriterT Parser (a, Set Path)
p)) JSONPathElement
e = do
  forall a. WriterT (Set Path) Parser a -> Parser a
Parser (forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (Parser (a, Set Path)
p forall a. Parser a -> JSONPathElement -> Parser a
Aeson.<?> JSONPathElement
e)) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* JSONPathElement -> Parser ()
markConsumed (JSONPathElement -> JSONPathElement
fromAesonPathElement JSONPathElement
e)

markConsumed :: JSONPathElement -> Parser ()
markConsumed :: JSONPathElement -> Parser ()
markConsumed JSONPathElement
e = do
  JSONPath
path <- Parser JSONPath
getPath
  forall a. WriterT (Set Path) Parser a -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. a -> Set a
Set.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONPath -> Path
Consumed forall a b. (a -> b) -> a -> b
$ JSONPathElement
e forall a. a -> [a] -> [a]
: JSONPath
path)

markDeprecated :: Key -> Key -> Parser ()
markDeprecated :: Key -> Key -> Parser ()
markDeprecated (Key -> Text
Key.toText -> Text
name) (Key -> Text
Key.toText -> Text
substitute) = do
  JSONPath
path <- Parser JSONPath
getPath
  forall a. WriterT (Set Path) Parser a -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ JSONPath -> JSONPath -> Path
Deprecated (Text -> JSONPathElement
Key Text
name forall a. a -> [a] -> [a]
: JSONPath
path) (Text -> JSONPathElement
Key Text
substitute forall a. a -> [a] -> [a]
: JSONPath
path))

getPath :: Parser JSONPath
getPath :: Parser JSONPath
getPath = forall a. Parser a -> Parser a
liftParser forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> (JSONPath -> [Char] -> Parser a) -> Parser a
Aeson.parserCatchError forall (f :: * -> *) a. Alternative f => f a
empty forall a b. (a -> b) -> a -> b
$ \ JSONPath
path [Char]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (JSONPath -> JSONPath
fromAesonPath JSONPath
path)

explicitParseField :: (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField :: forall a. (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField Value -> Parser a
p Object
o Key
key = case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key Object
o of
  Maybe Value
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Key
key forall a. [a] -> [a] -> [a]
++ [Char]
" not present"
  Just Value
v  -> Value -> Parser a
p Value
v forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Aeson.Key Key
key

explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe :: forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe Value -> Parser a
p Object
o Key
key = case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key Object
o of
  Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  Just Value
v  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
p Value
v forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Aeson.Key Key
key

typeMismatch :: String -> Value -> Parser a
typeMismatch :: forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
expected = forall a. Parser a -> Parser a
liftParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> Value -> Parser a
Aeson.typeMismatch [Char]
expected

withObject :: (Object -> Parser a) -> Value -> Parser a
withObject :: forall a. (Object -> Parser a) -> Value -> Parser a
withObject Object -> Parser a
p (Object Object
o) = Object -> Parser a
p Object
o
withObject Object -> Parser a
_ Value
v = forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Object" Value
v

withText :: (Text -> Parser a) -> Value -> Parser a
withText :: forall a. (Text -> Parser a) -> Value -> Parser a
withText Text -> Parser a
p (String Text
s) = Text -> Parser a
p Text
s
withText Text -> Parser a
_ Value
v = forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"String" Value
v

withString :: (String -> Parser a) -> Value -> Parser a
withString :: forall a. ([Char] -> Parser a) -> Value -> Parser a
withString [Char] -> Parser a
p = forall a. (Text -> Parser a) -> Value -> Parser a
withText ([Char] -> Parser a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

withArray :: (Array -> Parser a) -> Value -> Parser a
withArray :: forall a. (Array -> Parser a) -> Value -> Parser a
withArray Array -> Parser a
p (Array Array
xs) = Array -> Parser a
p Array
xs
withArray Array -> Parser a
_ Value
v = forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Array" Value
v

withNumber :: (Scientific -> Parser a) -> Value -> Parser a
withNumber :: forall a. (Scientific -> Parser a) -> Value -> Parser a
withNumber Scientific -> Parser a
p (Number Scientific
n) = Scientific -> Parser a
p Scientific
n
withNumber Scientific -> Parser a
_ Value
v = forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Number" Value
v

withBool :: (Bool -> Parser a) -> Value -> Parser a
withBool :: forall a. (Bool -> Parser a) -> Value -> Parser a
withBool Bool -> Parser a
p (Bool Bool
b) = Bool -> Parser a
p Bool
b
withBool Bool -> Parser a
_ Value
v = forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Boolean" Value
v