{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}

module Data.Aeson.WarningParser
  ( WarningParser
  , JSONWarning (..)
  , WithJSONWarnings (..)
  , withObjectWarnings
  , jsonSubWarnings
  , jsonSubWarningsT
  , jsonSubWarningsTT
  , logJSONWarnings
  , noJSONWarnings
  , tellJSONField
  , unWarningParser
  , (.:)
  , (.:?)
  , (..:)
  , (...:)
  , (..:?)
  , (...:?)
  , (..!=)
  ) where

import           Control.Monad.Trans.Writer.Strict
                   ( WriterT, mapWriterT, runWriterT, tell )
import qualified Data.Aeson as A
import           Data.Aeson.Types hiding ( (.:), (.:?) )
import qualified Data.Set as Set
import           Data.Text ( unpack )
import qualified Data.Text as T
import           Generics.Deriving.Monoid ( mappenddefault, memptydefault )
import           RIO
import           RIO.PrettyPrint.StylesUpdate ( StylesUpdate )

#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key
import qualified Data.Aeson.KeyMap as HashMap

keyToText :: Data.Aeson.Key.Key -> Text
keyToText :: Key -> Text
keyToText = Key -> Text
Data.Aeson.Key.toText

textToKey :: Text -> Data.Aeson.Key.Key
textToKey :: Text -> Key
textToKey = Text -> Key
Data.Aeson.Key.fromText
#else
import qualified Data.HashMap.Strict as HashMap

keyToText :: Text -> Text
keyToText = id

textToKey :: Text -> Text
textToKey = id
#endif

-- | Extends the @.:@ warning to include the field name that failed to parse.

(.:) :: FromJSON a => Object -> Text -> Parser a
.: :: forall a. FromJSON a => Object -> Text -> Parser a
(.:) Object
o Text
p = forall a. (String -> String) -> Parser a -> Parser a
modifyFailure
  ((String
"failed to parse field '" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
p forall a. Semigroup a => a -> a -> a
<> String
"': ") forall a. Semigroup a => a -> a -> a
<>)
  (Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Text -> Key
textToKey Text
p)
{-# INLINE (.:) #-}

-- | Extends the @.:?@ warning to include the field name that failed to parse.

(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
.:? :: forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
(.:?) Object
o Text
p = forall a. (String -> String) -> Parser a -> Parser a
modifyFailure
  ((String
"failed to parse field '" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
p forall a. Semigroup a => a -> a -> a
<> String
"': ") forall a. Semigroup a => a -> a -> a
<>)
  (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Text -> Key
textToKey Text
p)
{-# INLINE (.:?) #-}

-- | 'WarningParser' version of @.:@.

(..:) ::
     FromJSON a
  => Object
  -> Text
  -> WarningParser a
Object
o ..: :: forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
k = Text -> WarningParser ()
tellJSONField Text
k forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
k)

-- | 'WarningParser' version of @.:?@.

(..:?) ::
     FromJSON a
  => Object
  -> Text
  -> WarningParser (Maybe a)
Object
o ..:? :: forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
k = Text -> WarningParser ()
tellJSONField Text
k forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Object
o forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
k)

-- | 'WarningParser' version of @.!=@.

(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
WarningParser (Maybe a)
wp ..!= :: forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= a
d =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT WarningParser (Maybe a)
wp forall a b. (a -> b) -> a -> b
$
  \Parser (Maybe a, WarningParserMonoid)
p -> do
    WarningParserMonoid
a <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Parser (Maybe a, WarningParserMonoid)
p
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, WarningParserMonoid
a) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Parser (Maybe a, WarningParserMonoid)
p forall a. Parser (Maybe a) -> a -> Parser a
.!= a
d)

presentCount :: Object -> [Text] -> Int
presentCount :: Object -> [Text] -> Int
presentCount Object
o = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
x -> forall a. Key -> KeyMap a -> Bool
HashMap.member (Text -> Key
textToKey Text
x) Object
o)

-- | Synonym version of @..:@.

(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
Object
_ ...: :: forall a. FromJSON a => Object -> [Text] -> WarningParser a
...: [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to find an empty key"
Object
o ...: ss :: [Text]
ss@(Text
key:[Text]
_) = WriterT WarningParserMonoid Parser a
apply
 where
  pc :: Int
pc = Object -> [Text] -> Int
presentCount Object
o [Text]
ss
  apply :: WriterT WarningParserMonoid Parser a
apply | Int
pc forall a. Eq a => a -> a -> Bool
== Int
0   = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                        String
"failed to parse field " forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => a -> String
show Text
key forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
                        String
"keys " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Text]
ss forall a. [a] -> [a] -> [a]
++ String
" not present"
        | Int
pc forall a. Ord a => a -> a -> Bool
>  Int
1   = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                        String
"failed to parse field " forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => a -> String
show Text
key forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
                        String
"two or more synonym keys " forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => a -> String
show [Text]
ss forall a. [a] -> [a] -> [a]
++ String
" present"
        | Bool
otherwise = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Object
oforall a. FromJSON a => Object -> Text -> WarningParser a
..:) [Text]
ss

-- | Synonym version of @..:?@.

(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
Object
_ ...:? :: forall a. FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
...:? [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to find an empty key"
Object
o ...:? ss :: [Text]
ss@(Text
key:[Text]
_) = WriterT WarningParserMonoid Parser (Maybe a)
apply
 where
  pc :: Int
pc = Object -> [Text] -> Int
presentCount Object
o [Text]
ss
  apply :: WriterT WarningParserMonoid Parser (Maybe a)
apply | Int
pc forall a. Eq a => a -> a -> Bool
== Int
0   = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        | Int
pc forall a. Ord a => a -> a -> Bool
>  Int
1   = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                        String
"failed to parse field " forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => a -> String
show Text
key forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
                        String
"two or more synonym keys " forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => a -> String
show [Text]
ss forall a. [a] -> [a] -> [a]
++ String
" present"
        | Bool
otherwise = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Object
oforall a. FromJSON a => Object -> Text -> WarningParser a
..:) [Text]
ss

-- | Tell the warning parser about an expected field, so it doesn't warn about

-- it.

tellJSONField :: Text -> WarningParser ()
tellJSONField :: Text -> WarningParser ()
tellJSONField Text
key = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (forall a. Monoid a => a
mempty { wpmExpectedFields :: Set Text
wpmExpectedFields = forall a. a -> Set a
Set.singleton Text
key})

-- | 'WarningParser' version of 'withObject'.

withObjectWarnings ::
     String
  -> (Object -> WarningParser a)
  -> Value
  -> Parser (WithJSONWarnings a)
withObjectWarnings :: forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
expected Object -> WarningParser a
f =
  forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
expected forall a b. (a -> b) -> a -> b
$
  \Object
obj -> do
    (a
a,WarningParserMonoid
w) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Object -> WarningParser a
f Object
obj)
    let unrecognizedFields :: [Text]
unrecognizedFields =
          forall a. Set a -> [a]
Set.toList
            ( forall a. Ord a => Set a -> Set a -> Set a
Set.difference
                (forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
keyToText (forall v. KeyMap v -> [Key]
HashMap.keys Object
obj)))
                (WarningParserMonoid -> Set Text
wpmExpectedFields WarningParserMonoid
w)
            )
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall a. a -> [JSONWarning] -> WithJSONWarnings a
WithJSONWarnings a
a
          ( WarningParserMonoid -> [JSONWarning]
wpmWarnings WarningParserMonoid
w forall a. [a] -> [a] -> [a]
++
            case [Text]
unrecognizedFields of
                [] -> []
                [Text]
_ -> [String -> [Text] -> JSONWarning
JSONUnrecognizedFields String
expected [Text]
unrecognizedFields]
          )
      )

-- | Convert a 'WarningParser' to a 'Parser'.

unWarningParser :: WarningParser a -> Parser a
unWarningParser :: forall a. WarningParser a -> Parser a
unWarningParser WarningParser a
wp = do
  (a
a,WarningParserMonoid
_) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WarningParser a
wp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Log JSON warnings.

logJSONWarnings ::
     (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
  => FilePath
  -> [JSONWarning]
  -> m ()
logJSONWarnings :: forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings String
fp =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\JSONWarning
w -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Warning: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
fp forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow JSONWarning
w))

-- | Handle warnings in a sub-object.

jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings :: forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings WarningParser (WithJSONWarnings a)
f = do
  WithJSONWarnings a
result [JSONWarning]
warnings <- WarningParser (WithJSONWarnings a)
f
  forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell
    ( forall a. Monoid a => a
mempty
        { wpmWarnings :: [JSONWarning]
wpmWarnings = [JSONWarning]
warnings
        }
    )
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | Handle warnings in a @Traversable@ of sub-objects.

jsonSubWarningsT ::
     Traversable t
  => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT :: forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT WarningParser (t (WithJSONWarnings a))
f =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WarningParser (t (WithJSONWarnings a))
f

-- | Handle warnings in a @Maybe Traversable@ of sub-objects.

jsonSubWarningsTT ::
     (Traversable t, Traversable u)
  => WarningParser (u (t (WithJSONWarnings a)))
  -> WarningParser (u (t a))
jsonSubWarningsTT :: forall (t :: * -> *) (u :: * -> *) a.
(Traversable t, Traversable u) =>
WarningParser (u (t (WithJSONWarnings a)))
-> WarningParser (u (t a))
jsonSubWarningsTT WarningParser (u (t (WithJSONWarnings a)))
f =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< WarningParser (u (t (WithJSONWarnings a)))
f

-- Parsed JSON value without any warnings.

noJSONWarnings :: a -> WithJSONWarnings a
noJSONWarnings :: forall a. a -> WithJSONWarnings a
noJSONWarnings a
v = forall a. a -> [JSONWarning] -> WithJSONWarnings a
WithJSONWarnings a
v []

-- | A JSON parser that warns about unexpected fields in objects.

type WarningParser a = WriterT WarningParserMonoid Parser a

-- | Monoid used by 'WarningParser' to track expected fields and warnings.

data WarningParserMonoid = WarningParserMonoid
  { WarningParserMonoid -> Set Text
wpmExpectedFields :: !(Set Text)
  , WarningParserMonoid -> [JSONWarning]
wpmWarnings :: [JSONWarning]
  } deriving forall x. Rep WarningParserMonoid x -> WarningParserMonoid
forall x. WarningParserMonoid -> Rep WarningParserMonoid x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WarningParserMonoid x -> WarningParserMonoid
$cfrom :: forall x. WarningParserMonoid -> Rep WarningParserMonoid x
Generic

instance Semigroup WarningParserMonoid where
  <> :: WarningParserMonoid -> WarningParserMonoid -> WarningParserMonoid
(<>) = forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault

instance Monoid WarningParserMonoid where
  mempty :: WarningParserMonoid
mempty = forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
  mappend :: WarningParserMonoid -> WarningParserMonoid -> WarningParserMonoid
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance IsString WarningParserMonoid where
  fromString :: String -> WarningParserMonoid
fromString String
s = forall a. Monoid a => a
mempty { wpmWarnings :: [JSONWarning]
wpmWarnings = [forall a. IsString a => String -> a
fromString String
s] }

-- Parsed JSON value with its warnings.

data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
  deriving (WithJSONWarnings a -> WithJSONWarnings a -> Bool
forall a. Eq a => WithJSONWarnings a -> WithJSONWarnings a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WithJSONWarnings a -> WithJSONWarnings a -> Bool
$c/= :: forall a. Eq a => WithJSONWarnings a -> WithJSONWarnings a -> Bool
== :: WithJSONWarnings a -> WithJSONWarnings a -> Bool
$c== :: forall a. Eq a => WithJSONWarnings a -> WithJSONWarnings a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WithJSONWarnings a) x -> WithJSONWarnings a
forall a x. WithJSONWarnings a -> Rep (WithJSONWarnings a) x
$cto :: forall a x. Rep (WithJSONWarnings a) x -> WithJSONWarnings a
$cfrom :: forall a x. WithJSONWarnings a -> Rep (WithJSONWarnings a) x
Generic, Int -> WithJSONWarnings a -> String -> String
forall a. Show a => Int -> WithJSONWarnings a -> String -> String
forall a. Show a => [WithJSONWarnings a] -> String -> String
forall a. Show a => WithJSONWarnings a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [WithJSONWarnings a] -> String -> String
$cshowList :: forall a. Show a => [WithJSONWarnings a] -> String -> String
show :: WithJSONWarnings a -> String
$cshow :: forall a. Show a => WithJSONWarnings a -> String
showsPrec :: Int -> WithJSONWarnings a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> WithJSONWarnings a -> String -> String
Show)

instance Functor WithJSONWarnings where
  fmap :: forall a b. (a -> b) -> WithJSONWarnings a -> WithJSONWarnings b
fmap a -> b
f (WithJSONWarnings a
x [JSONWarning]
w) = forall a. a -> [JSONWarning] -> WithJSONWarnings a
WithJSONWarnings (a -> b
f a
x) [JSONWarning]
w

instance Monoid a => Semigroup (WithJSONWarnings a) where
  <> :: WithJSONWarnings a -> WithJSONWarnings a -> WithJSONWarnings a
(<>) = forall a. (Generic a, Monoid' (Rep a)) => a -> a -> a
mappenddefault

instance Monoid a => Monoid (WithJSONWarnings a) where
  mempty :: WithJSONWarnings a
mempty = forall a. (Generic a, Monoid' (Rep a)) => a
memptydefault
  mappend :: WithJSONWarnings a -> WithJSONWarnings a -> WithJSONWarnings a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Warning output from 'WarningParser'.

data JSONWarning
  = JSONUnrecognizedFields String [Text]
  | JSONGeneralWarning !Text
  deriving JSONWarning -> JSONWarning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONWarning -> JSONWarning -> Bool
$c/= :: JSONWarning -> JSONWarning -> Bool
== :: JSONWarning -> JSONWarning -> Bool
$c== :: JSONWarning -> JSONWarning -> Bool
Eq

instance Show JSONWarning where
  show :: JSONWarning -> String
show = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance Display JSONWarning where
  display :: JSONWarning -> Utf8Builder
display (JSONUnrecognizedFields String
obj [Text
field]) =
    Utf8Builder
"Unrecognized field in " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
obj forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
field
  display (JSONUnrecognizedFields String
obj [Text]
fields) =
       Utf8Builder
"Unrecognized fields in "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
obj
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
fields)
  display (JSONGeneralWarning Text
t) = forall a. Display a => a -> Utf8Builder
display Text
t

instance IsString JSONWarning where
  fromString :: String -> JSONWarning
fromString = Text -> JSONWarning
JSONGeneralWarning forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance FromJSON (WithJSONWarnings StylesUpdate) where
  parseJSON :: Value -> Parser (WithJSONWarnings StylesUpdate)
parseJSON Value
v = forall a. a -> WithJSONWarnings a
noJSONWarnings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v