module Data.Aeson.Extended (
module Export
, (.:)
, (.:?)
, JSONWarning (..)
, WarningParser
, WithJSONWarnings (..)
, withObjectWarnings
, jsonSubWarnings
, jsonSubWarningsT
, jsonSubWarningsTT
, logJSONWarnings
, noJSONWarnings
, tellJSONField
, unWarningParser
, (..:)
, (..:?)
, (..!=)
) where
import Control.Monad.Logger (MonadLogger, logWarn)
import Control.Monad.Trans (lift)
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 Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (unpack, Text)
import qualified Data.Text as T
import Data.Traversable
import qualified Data.Traversable as Traversable
import Prelude
(.:) :: FromJSON a => Object -> Text -> Parser a
(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
(..:)
:: 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)
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
:: MonadLogger m
=> FilePath -> [JSONWarning] -> m ()
logJSONWarnings fp =
mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show 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 =
Traversable.mapM (jsonSubWarnings . return) =<< f
jsonSubWarningsTT
:: (Traversable t, Traversable u)
=> WarningParser (u (t (WithJSONWarnings a)))
-> WarningParser (u (t a))
jsonSubWarningsTT f =
Traversable.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]
}
instance Monoid WarningParserMonoid where
mempty = WarningParserMonoid Set.empty []
mappend a b =
WarningParserMonoid
{ wpmExpectedFields = Set.union
(wpmExpectedFields a)
(wpmExpectedFields b)
, wpmWarnings = wpmWarnings a ++ wpmWarnings b
}
data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
instance Functor WithJSONWarnings where
fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
instance Monoid a => Monoid (WithJSONWarnings a) where
mempty = noJSONWarnings mempty
mappend (WithJSONWarnings a aw) (WithJSONWarnings b bw) = WithJSONWarnings (mappend a b) (mappend aw bw)
data JSONWarning = JSONUnrecognizedFields String [Text]
instance Show JSONWarning where
show (JSONUnrecognizedFields obj [field]) =
"Unrecognized field in " <> obj <> ": " <> T.unpack field
show (JSONUnrecognizedFields obj fields) =
"Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)