aeson-value-parser 0.13.1 → 0.14

raw patch · 5 files changed

+151/−110 lines, 5 filesdep −foldldep −json-pointerdep −json-pointer-aesonPVP ok

version bump matches the API change (PVP)

Dependencies removed: foldl, json-pointer, json-pointer-aeson

API changes (from Hackage documentation)

Files

• aeson-value-parser.cabal +3/−4
• library/Aeson/ValueParser.hs +100/−99
• library/Aeson/ValueParser/Error.hs +29/−0
• library/Aeson/ValueParser/Prelude.hs +8/−7
• library/Aeson/ValueParser/Vector.hs +11/−0

@@ -1,5 +1,5 @@ name: aeson-value-parser-version: 0.13.1+version: 0.14 synopsis: An API for parsing "aeson" JSON tree into Haskell types description: category: Data, JSON, Parsing@@ -24,14 +24,13 @@   exposed-modules:     Aeson.ValueParser   other-modules:+    Aeson.ValueParser.Error     Aeson.ValueParser.Prelude+    Aeson.ValueParser.Vector   build-depends:     aeson ==1.*,     base >=4.9 && <5,     bytestring >=0.10 && <0.12,-    foldl >=1.3 && <2,-    json-pointer ==0.1.*,-    json-pointer-aeson ==0.1.*,     mtl >=2.2 && <3,     scientific ==0.3.*,     text ==1.*,

@@ -4,6 +4,7 @@ (   Value,   run,+  Error.Error(..),   -- * Value parsers   object,   array,@@ -15,96 +16,98 @@   numberAsInt,   bool,   fromJSON,-  pointed,   -- * Object parsers   Object,   field,-  eitherField,-  fieldsMap,-  foldFields,+  oneOfFields,+  fieldMap,   foldlFields,   -- * Array parsers   Array,   element,-  elementsVector,-  foldElements,+  elementVector,   foldlElements,-  foldlElements1,   foldrElements, ) where  import Aeson.ValueParser.Prelude hiding (bool, null)-import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as B-import qualified Data.Vector as C-import qualified Data.Text.Encoding as F-import qualified JSONPointer.Model as D-import qualified JSONPointer.Aeson.Interpreter as E+import qualified Aeson.ValueParser.Error as Error+import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap import qualified Data.Scientific as Scientific+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as Vector+import qualified Aeson.ValueParser.Vector as Vector  +-- * Value+-------------------------+ -- |--- A JSON 'A.Value' parser.+-- A JSON 'Aeson.Value' parser. newtype Value a =-  Value (ReaderT A.Value (Except Text) a)-  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)+  Value (ReaderT Aeson.Value (Except Error.Error) a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Error.Error) +instance MonadFail Value where+  fail = throwError . fromString+ {-# INLINE run #-}-run :: Value a -> A.Value -> Either Text a+run :: Value a -> Aeson.Value -> Either Error.Error a run (Value effect) = runExcept . runReaderT effect --- * Value parsers+-- ** Definitions ------------------------- -{-# INLINE aesonMatcher #-}-aesonMatcher :: (A.Value -> Either Text a) -> Value a-aesonMatcher matcher = Value $ ReaderT $ either (except . Left) pure . matcher+{-# INLINE astMatcher #-}+astMatcher :: (Aeson.Value -> Either Text a) -> Value a+astMatcher matcher = Value $ ReaderT $ except . left Error.message . matcher  {-# INLINE array #-} array :: Array a -> Value a-array (Array effect) = Value $ ReaderT $ \ case-  A.Array x -> runReaderT effect x-  _ -> (except . Left) "Not an array"+array (Array parser) = Value $ ReaderT $ \ case+  Aeson.Array x -> runReaderT parser x+  _ -> throwError "Not an array"  {-# INLINE object #-} object :: Object a -> Value a object (Object effect) = Value $ ReaderT $ \ case-  A.Object x -> runReaderT effect x-  _ -> (except . Left) "Not an object"+  Aeson.Object x -> runReaderT effect x+  _ -> throwError "Not an object"  {-# INLINE null #-} null :: Value ()-null = aesonMatcher $ \ case-  A.Null -> pure ()+null = astMatcher $ \ case+  Aeson.Null -> pure ()   _ -> Left "Not null"  {-# INLINE nullable #-} nullable :: Value a -> Value (Maybe a)-nullable (Value impl) = Value $ ReaderT $ \ case-  A.Null -> pure Nothing-  x -> fmap Just (runReaderT impl x)+nullable (Value parser) = Value $ ReaderT $ \ case+  Aeson.Null -> pure Nothing+  x -> fmap Just (runReaderT parser x)  {-# INLINE string #-} string :: Value Text-string = aesonMatcher $ \ case-  A.String t -> pure t+string = astMatcher $ \ case+  Aeson.String t -> pure t   _ -> Left "Not a string"  {-# INLINE stringAsBytes #-} stringAsBytes :: Value ByteString-stringAsBytes = F.encodeUtf8 <$> string+stringAsBytes = Text.encodeUtf8 <$> string  {-# INLINE number #-} number :: Value Scientific-number = aesonMatcher $ \ case-  A.Number x -> pure x+number = astMatcher $ \ case+  Aeson.Number x -> pure x   _ -> Left "Not a number"  {-# INLINE numberAsInt #-} numberAsInt :: Value Int-numberAsInt = aesonMatcher $ \case-  A.Number x -> if Scientific.isInteger x+numberAsInt = astMatcher $ \case+  Aeson.Number x -> if Scientific.isInteger x     then case Scientific.toBoundedInteger x of       Just int -> Right int       Nothing -> Left ("Number " <> showText x <> " is out of integer range")@@ -113,96 +116,94 @@  {-# INLINE bool #-} bool :: Value Bool-bool = aesonMatcher $ \ case-  A.Bool x -> pure x+bool = astMatcher $ \ case+  Aeson.Bool x -> pure x   _ -> Left "Not a bool"  {-# INLINE fromJSON #-}-fromJSON :: A.FromJSON a => Value a-fromJSON = Value $ ReaderT $ A.fromJSON >>> \ case-  A.Error m -> (except . Left) (fromString m)-  A.Success r -> pure r--{-|-Lifts JSON Pointer.--}-{-# INLINE pointed #-}-pointed :: D.JSONPointer -> Value a -> Value a-pointed pointer parser = aesonMatcher $ \ value -> case E.value pointer value of-  Nothing -> Left (fromString (showString "Pointer \"" $ shows pointer "\" points to nothing"))-  Just pointedValue -> run parser pointedValue+fromJSON :: Aeson.FromJSON a => Value a+fromJSON = Value $ ReaderT $ Aeson.fromJSON >>> \ case+  Aeson.Error m -> (except . Left) (fromString m)+  Aeson.Success r -> pure r   -- * Object parsers -------------------------  -- |--- A JSON 'A.Object' parser.+-- A JSON 'Aeson.Object' parser. newtype Object a =-  Object (ReaderT A.Object (Except Text) a)-  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)+  Object (ReaderT (HashMap Text Aeson.Value) (Except Error.Error) a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Error.Error) +instance MonadFail Object where+  fail = throwError . fromString+ {-# INLINE field #-} field :: Text -> Value a -> Object a-field key (Value effect) = Object $ ReaderT $-  maybe ((except . Left) $ "Object contains no field '" <> key <> "'") (runReaderT effect) .-  B.lookup key--{-# INLINE eitherField #-}-eitherField :: [Text] -> Value value -> Object value-eitherField list valueParser =-  asum (fmap (\ key -> field key valueParser) list) +field key (Value effect) = Object $ ReaderT $ \ object -> except $ case HashMap.lookup key object of+  Just value -> case runExcept (runReaderT effect value) of+    Left (Error.Error path message) -> Left (Error.Error (key : path) message)+    Right parsedValue -> Right parsedValue+  Nothing -> Left (Error.Error (pure key) "Object contains no such key") -{-# INLINE fieldsMap #-}-fieldsMap :: Value a -> Object (B.HashMap Text a)-fieldsMap (Value effect) = Object $ ReaderT $ mapM (runReaderT effect)+{-# INLINE oneOfFields #-}+oneOfFields :: [Text] -> Value a -> Object a+oneOfFields keys valueParser = asum (fmap (flip field valueParser) keys) -{-# INLINE foldFields #-}-foldFields :: Fold (Text, field) object -> Value field -> Object object-foldFields (Fold foldStep foldInit foldEnd) value = fmap foldEnd (foldlFields foldStep foldInit value)+{-# INLINE fieldMap #-}+fieldMap :: Value a -> Object (HashMap Text a)+fieldMap fieldParser = Object $ ReaderT $ except . HashMap.traverseWithKey mapping where+  mapping key ast = case run fieldParser ast of+    Right parsedField -> return parsedField+    Left error -> Left (Error.named key error)  {-# INLINE foldlFields #-}-foldlFields :: (a -> (Text, b) -> a) -> a -> Value b -> Object a-foldlFields step init (Value impl) = Object $ ReaderT $ B.foldlWithKey' step' (pure init) where-  step' acc' key value = acc' >>= \acc -> fmap (step acc . (,) key) (runReaderT impl value)+foldlFields :: (state -> Text -> field -> state) -> state -> Value field -> Object state+foldlFields step state fieldParser = Object $ ReaderT $ \ object -> except $ HashMap.foldlWithKey' newStep (pure state) object where+  newStep stateEither key fieldAst = case run fieldParser fieldAst of+    Right !parsedField -> do+      !state <- stateEither+      return $ step state key parsedField+    Left error -> Left (Error.named key error)   -- * Array parsers -------------------------  -- |--- A JSON 'A.Array' parser.+-- A JSON 'Aeson.Array' parser. newtype Array a =-  Array (ReaderT A.Array (Except Text) a)-  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)+  Array (ReaderT (Vector Aeson.Value) (Except Error.Error) a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Error.Error) +instance MonadFail Array where+  fail = throwError . fromString+ {-# INLINE element #-} element :: Int -> Value a -> Array a-element element (Value effect) = Array $ ReaderT $-  maybe ((except . Left) $ "Array has no element '" <> (fromString . show) element <> "'") (runReaderT effect) .-  flip (C.!?) element--{-# INLINE elementsVector #-}-elementsVector :: Value a -> Array (C.Vector a)-elementsVector (Value effect) = Array $ ReaderT $ mapM (runReaderT effect)+element index elementParser = Array $ ReaderT $ \ array -> except $ case array Vector.!? index of+  Just element -> case run elementParser element of+    Right result -> Right result+    Left error -> Left (Error.indexed index error)+  Nothing -> Left (Error.Error (pure (fromString (show index))) "Array contains no element by this index") -{-# INLINE foldElements #-}-foldElements :: Fold element array -> Value element -> Array array-foldElements (Fold foldStep foldInit foldEnd) value = fmap foldEnd (foldlElements foldStep foldInit value)+{-# INLINE elementVector #-}+elementVector :: Value a -> Array (Vector a)+elementVector elementParser = Array $ ReaderT $ \ arrayAst -> except $ flip Vector.imapM arrayAst $ \ index ast -> case run elementParser ast of+  Right element -> Right element+  Left error -> Left (Error.indexed index error)  {-# INLINE foldlElements #-}-foldlElements :: (a -> b -> a) -> a -> Value b -> Array a-foldlElements step init (Value impl) = Array $ ReaderT $ foldlM step' init where-  step' acc element = fmap (step acc) (runReaderT impl element)+foldlElements :: (state -> Int -> element -> state) -> state -> Value element -> Array state+foldlElements step state elementParser = Array $ ReaderT $ except . Vector.ifoldM' newStep state where+  newStep state index ast = case run elementParser ast of+    Right !element -> Right $ step state index element+    Left error -> Left (Error.indexed index error)  {-# INLINE foldrElements #-}-foldrElements :: (b -> a -> a) -> a -> Value b -> Array a-foldrElements step init (Value impl) = Array $ ReaderT $ foldrM step' init where-  step' element acc = fmap (flip step acc) (runReaderT impl element)--{-# INLINE foldlElements1 #-}-foldlElements1 :: (a -> a -> a) -> Value a -> Array a-foldlElements1 step value =-  foldlElements (\acc input -> maybe (Just input) (Just . flip step input) acc) Nothing value >>= \ case-    Nothing -> Array $ lift $ (except . Left) "Empty array"-    Just x -> pure x+foldrElements :: (Int -> element -> state -> state) -> state -> Value element -> Array state+foldrElements step state elementParser = Array $ ReaderT $ except . Vector.ifoldrM newStep state where+  newStep index ast nextState = case run elementParser ast of+    Right !element -> Right $ step index element nextState+    Left error -> Left (Error.indexed index error)

@@ -0,0 +1,29 @@+module Aeson.ValueParser.Error+where++import Aeson.ValueParser.Prelude+++data Error = Error [Text] {-^ Path -} Text {-^ Message -}++instance Semigroup Error where+  (<>) a _ = a++instance Monoid Error where+  mempty = Error [] ""+  mappend = (<>)++instance IsString Error where+  fromString = message . fromString++{-# INLINE indexed #-}+indexed :: Int -> Error -> Error+indexed = named . fromString . show++{-# INLINE named #-}+named :: Text -> Error -> Error+named name (Error path message) = Error (name : path) message++{-# INLINE message #-}+message :: Text -> Error+message = Error []

@@ -13,8 +13,9 @@ import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM) import Control.Monad.IO.Class as Exports+import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix) import Control.Monad.ST as Exports import Data.Bits as Exports@@ -57,7 +58,7 @@ import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import Numeric as Exports-import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -72,10 +73,6 @@ import Text.Read as Exports (Read(..), readMaybe, readEither) import Unsafe.Coerce as Exports --- foldl---------------------------import Control.Foldl as Exports (Fold(..), FoldM(..))- -- transformers ------------------------- import Control.Monad.Trans.Class as Exports@@ -84,7 +81,7 @@  -- mtl --------------------------import Control.Monad.Error.Class as Exports+import Control.Monad.Error.Class as Exports hiding (Error)  -- bytestring -------------------------@@ -97,6 +94,10 @@ -- unordered-containers ------------------------- import Data.HashMap.Strict as Exports (HashMap)++-- vector+-------------------------+import Data.Vector as Exports (Vector)  -- scientific -------------------------

@@ -0,0 +1,11 @@+module Aeson.ValueParser.Vector+where++import Aeson.ValueParser.Prelude hiding (Vector)+import Data.Vector.Generic+import qualified Data.Vector.Fusion.Bundle.Monadic as BundleM+++{-# INLINE ifoldrM #-}+ifoldrM :: (Vector v a, Monad m) => (Int -> a -> b -> m b) -> b -> v a -> m b+ifoldrM f z = BundleM.foldrM (uncurry f) z . BundleM.indexed . BundleM.fromVector