{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Pantry.Internal.AesonExtended (
module Export
, (.:)
, (.:?)
, 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.HashMap.Strict as HashMap
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)
(.:) :: FromJSON a => Object -> Text -> Parser a
(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
{-# INLINE (.:) #-}
(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
{-# INLINE (.:?) #-}
(..:)
:: FromJSON a
=> Object -> Text -> WarningParser a
o ..: k = tellJSONField k >> lift (o .: k)
(..:?)
:: FromJSON a
=> Object -> Text -> WarningParser (Maybe a)
o ..:? k = tellJSONField k >> lift (o .:? k)
(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
wp ..!= d =
flip mapWriterT wp $
\p ->
do a <- fmap snd p
fmap (, a) (fmap fst p .!= d)
presentCount :: Object -> [Text] -> Int
presentCount o ss = length . filter (\x -> HashMap.member x o) $ ss
(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
_ ...: [] = fail "failed to find an empty key"
o ...: ss@(key:_) = apply
where pc = presentCount o ss
apply | pc == 0 = fail $
"failed to parse field " ++
show key ++ ": " ++
"keys " ++ show ss ++ " not present"
| pc > 1 = fail $
"failed to parse field " ++
show key ++ ": " ++
"two or more synonym keys " ++
show ss ++ " present"
| otherwise = asum $ map (o..:) ss
(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
_ ...:? [] = fail "failed to find an empty key"
o ...:? ss@(key:_) = apply
where pc = presentCount o ss
apply | pc == 0 = return Nothing
| pc > 1 = fail $
"failed to parse field " ++
show key ++ ": " ++
"two or more synonym keys " ++
show ss ++ " present"
| otherwise = asum $ map (o..:) ss
tellJSONField :: Text -> WarningParser ()
tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
withObjectWarnings :: String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings expected f =
withObject expected $
\obj ->
do (a,w) <- runWriterT (f obj)
let unrecognizedFields =
Set.toList
(Set.difference
(Set.fromList (HashMap.keys obj))
(wpmExpectedFields w))
return
(WithJSONWarnings a
(wpmWarnings w ++
case unrecognizedFields of
[] -> []
_ -> [JSONUnrecognizedFields expected unrecognizedFields]))
unWarningParser :: WarningParser a -> Parser a
unWarningParser wp = do
(a,_) <- runWriterT wp
return a
logJSONWarnings
:: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
=> FilePath -> [JSONWarning] -> m ()
logJSONWarnings fp =
mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w))
jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings f = do
WithJSONWarnings result warnings <- f
tell
(mempty
{ wpmWarnings = warnings
})
return result
jsonSubWarningsT
:: Traversable t
=> WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT f =
mapM (jsonSubWarnings . return) =<< f
jsonSubWarningsTT
:: (Traversable t, Traversable u)
=> WarningParser (u (t (WithJSONWarnings a)))
-> WarningParser (u (t a))
jsonSubWarningsTT f =
mapM (jsonSubWarningsT . return) =<< f
noJSONWarnings :: a -> WithJSONWarnings a
noJSONWarnings v = WithJSONWarnings v []
type WarningParser a = WriterT WarningParserMonoid Parser a
data WarningParserMonoid = WarningParserMonoid
{ wpmExpectedFields :: !(Set Text)
, wpmWarnings :: [JSONWarning]
} deriving Generic
instance Semigroup WarningParserMonoid where
(<>) = mappenddefault
instance Monoid WarningParserMonoid where
mempty = memptydefault
mappend = (<>)
instance IsString WarningParserMonoid where
fromString s = mempty { wpmWarnings = [fromString s] }
data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
deriving (Eq, Generic, Show)
instance Functor WithJSONWarnings where
fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
instance Monoid a => Semigroup (WithJSONWarnings a) where
(<>) = mappenddefault
instance Monoid a => Monoid (WithJSONWarnings a) where
mempty = memptydefault
mappend = (<>)
data JSONWarning = JSONUnrecognizedFields String [Text]
| JSONGeneralWarning !Text
deriving Eq
instance Show JSONWarning where
show = T.unpack . utf8BuilderToText . display
instance Display JSONWarning where
display (JSONUnrecognizedFields obj [field]) =
"Unrecognized field in " <> fromString obj <> ": " <> display field
display (JSONUnrecognizedFields obj fields) =
"Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields)
display (JSONGeneralWarning t) = display t
instance IsString JSONWarning where
fromString = JSONGeneralWarning . T.pack
instance FromJSON (WithJSONWarnings StylesUpdate) where
parseJSON v = noJSONWarnings <$> parseJSON v