{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}
module Data.Aeson.Extended (
module Export
, (.:)
, (.:?)
, WarningParser
, JSONWarning (..)
, withObjectWarnings
, jsonSubWarnings
, jsonSubWarningsT
, jsonSubWarningsTT
, logJSONWarnings
, 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)
{-# 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)
tellJSONField :: Text -> WarningParser ()
tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
withObjectWarnings :: String
-> (Object -> WarningParser a)
-> Value
-> Parser (a, [JSONWarning])
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
( 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 (a, [JSONWarning]) -> WarningParser a
jsonSubWarnings f = do
(result,warnings) <- f
tell
(mempty
{ wpmWarnings = warnings
})
return result
jsonSubWarningsT
:: Traversable t
=> WarningParser (t (a, [JSONWarning])) -> WarningParser (t a)
jsonSubWarningsT f =
Traversable.mapM (jsonSubWarnings . return) =<< f
jsonSubWarningsTT
:: (Traversable t, Traversable u)
=> WarningParser (u (t (a, [JSONWarning])))
-> WarningParser (u (t a))
jsonSubWarningsTT f =
Traversable.mapM (jsonSubWarningsT . return) =<< f
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 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)