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

-- | Extensions to Aeson parsing of objects. This module is intended

-- for internal use by Pantry and Stack only. The intention is to

-- fully remove this module in the future. /DO NOT RELY ON IT/.

module Pantry.Internal.AesonExtended (
    module Export
  -- * Extended failure messages

  , (.:)
  , (.:?)
  -- * JSON Parser that emits warnings

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

import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
import Data.Aeson as Export hiding ((.:), (.:?))
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 @.:@ warning to include field name.

(.:) :: 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 @.:?@ warning to include field name.

(.:?) :: 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 [Text]
ss = 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) forall a b. (a -> b) -> a -> b
$ [Text]
ss

-- | 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 (m :: * -> *) a. Monad m => a -> m a
return 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 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 (m :: * -> *) a. Monad m => a -> m a
return
                (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return) 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 (m :: * -> *) a. Monad m => a -> m a
return) 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 []

-- | 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