aeson-value-parser 0.18.1 → 0.19

raw patch · 9 files changed

+494/−484 lines, 9 filesdep +megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec

API changes (from Hackage documentation)

Files

• aeson-value-parser.cabal +6/−5
• library/Aeson/ValueParser.hs +0/−311
• library/Aeson/ValueParser/Error.hs +0/−43
• library/Aeson/ValueParser/Prelude.hs +0/−114
• library/Aeson/ValueParser/Vector.hs +0/−11
• library/AesonValueParser.hs +319/−0
• library/AesonValueParser/Error.hs +43/−0
• library/AesonValueParser/Prelude.hs +115/−0
• library/AesonValueParser/Vector.hs +11/−0

@@ -1,5 +1,5 @@ name: aeson-value-parser-version: 0.18.1+version: 0.19 synopsis: API for parsing "aeson" JSON tree into Haskell types description:   A flexible parser DSL of JSON AST produced by the \"aeson\" library@@ -27,17 +27,18 @@   default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples   default-language: Haskell2010   exposed-modules:-    Aeson.ValueParser+    AesonValueParser   other-modules:-    Aeson.ValueParser.Error-    Aeson.ValueParser.Prelude-    Aeson.ValueParser.Vector+    AesonValueParser.Error+    AesonValueParser.Prelude+    AesonValueParser.Vector   build-depends:     aeson ==1.*,     attoparsec >=0.13 && <0.14,     base >=4.9 && <5,     bytestring >=0.10 && <0.12,     hashable >=1.3 && <2,+    megaparsec >=8 && <9,     mtl >=2.2 && <3,     scientific ==0.3.*,     text ==1.*,

@@ -1,311 +0,0 @@-{--Parser DSL for the \"aeson\" model of JSON tree.--The general model of this DSL is about switching between contexts.--}-module Aeson.ValueParser-(-  Value,-  run,-  runWithTextError,-  Error.Error(..),-  -- * Value parsers-  object,-  array,-  null,-  nullable,-  nullableMonoid,-  string,-  number,-  bool,-  fromJSON,-  -- * String parsers-  String,-  text,-  matchedText,-  parsedText,-  -- * Number parsers-  Number,-  scientific,-  integer,-  floating,-  matchedScientific,-  matchedInteger,-  matchedFloating,-  -- * Object parsers-  Object,-  field,-  oneOfFields,-  fieldMap,-  foldlFields,-  -- * Array parsers-  Array,-  element,-  elementVector,-  foldlElements,-  foldrElements,-)-where--import Aeson.ValueParser.Prelude hiding (bool, null, String)-import qualified Aeson.ValueParser.Error as Error-import qualified Data.Aeson as Aeson-import qualified Data.Attoparsec.Text as Attoparsec-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-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----------------------------{-|-JSON `Aeson.Value` AST parser.--Its `Alternative` instance implements the logic of choosing between the possible types of JSON values.--}-newtype Value a =-  Value (ReaderT Aeson.Value (MaybeT (Either Error.Error)) a)-  deriving (Functor, Applicative)--{-|-Implements the logic of choosing between the possible types of JSON values.--If you have multiple parsers of the same type of JSON value composed,-only the leftmost will be affective.-The errors from deeper parsers do not trigger the alternation,-instead they get propagated to the top.--}-instance Alternative Value where-  empty = Value $ ReaderT $ const $ MaybeT $ return Nothing-  (<|>) (Value leftParser) (Value rightParser) = Value (leftParser <|> rightParser)--{-# INLINE run #-}-run :: Value a -> Aeson.Value -> Either Error.Error a-run = \ (Value parser) value -> (=<<) (maybe (Left (typeError value)) Right) $ runMaybeT $ runReaderT parser value where-  typeError = \ case-    Aeson.Array _ -> "Unexpected type: array"-    Aeson.Object _ -> "Unexpected type: object"-    Aeson.String _ -> "Unexpected type: string"-    Aeson.Number _ -> "Unexpected type: number"-    Aeson.Bool _ -> "Unexpected type: bool"-    Aeson.Null -> "Unexpected type: null"--{-# INLINE runWithTextError #-}-runWithTextError :: Value a -> Aeson.Value -> Either Text a-runWithTextError parser = left Error.toText . run parser--runString :: String a -> Text -> Either (Maybe Text) a-runString (String a) b = runExcept (runReaderT a b)---- ** Definitions----------------------------{-# INLINE array #-}-array :: Array a -> Value a-array (Array parser) = Value $ ReaderT $ \ case-  Aeson.Array x -> lift $ join $ runExcept $ runExceptT $ runReaderT parser x-  _ -> empty--{-# INLINE object #-}-object :: Object a -> Value a-object (Object parser) = Value $ ReaderT $ \ case-  Aeson.Object x -> lift $ join $ runExcept $ runExceptT $ runReaderT parser x-  _ -> empty--{-# INLINE null #-}-null :: Value ()-null = Value $ ReaderT $ \ case-  Aeson.Null -> pure ()-  _ -> empty--{-# INLINE nullable #-}-nullable :: Value a -> Value (Maybe a)-nullable (Value parser) = Value $ ReaderT $ \ case-  Aeson.Null -> pure Nothing-  x -> fmap Just (runReaderT parser x)--{-# INLINE nullableMonoid #-}-nullableMonoid :: Monoid a => Value a -> Value a-nullableMonoid (Value parser) = Value $ ReaderT $ \ case-  Aeson.Null -> pure mempty-  x -> runReaderT parser x--{-# INLINE string #-}-string :: String a -> Value a-string (String parser) = Value $ ReaderT $ \ case-  Aeson.String x -> lift $ left (Error.message . fromMaybe "No details") $ runExcept $ runReaderT parser x-  _ -> empty--{-# INLINE number #-}-number :: Number a -> Value a-number (Number parser) = Value $ ReaderT $ \ case-  Aeson.Number x -> lift $ left (Error.message . fromMaybe "No details") $ runExcept $ runReaderT parser x-  _ -> empty--{-# INLINE bool #-}-bool :: Value Bool-bool = Value $ ReaderT $ \ case-  Aeson.Bool x -> return x-  _ -> empty--{-# INLINE fromJSON #-}-fromJSON :: Aeson.FromJSON a => Value a-fromJSON = Value $ ReaderT $ Aeson.fromJSON >>> \ case-  Aeson.Success r -> return r-  Aeson.Error m -> lift $ Left $ fromString m----- * String parsers----------------------------newtype String a =-  String (ReaderT Text (Except (Maybe Text)) a)-  deriving (Functor, Applicative, Alternative)--{-# INLINE text #-}-text :: String Text-text = String ask--{-# INLINE matchedText #-}-matchedText :: (Text -> Either Text a) -> String a-matchedText parser = String $ ReaderT $ except . left Just . parser--{-# INLINE parsedText #-}-parsedText :: Attoparsec.Parser a -> String a-parsedText parser = matchedText $ left fromString . Attoparsec.parseOnly parser----- * Number parsers----------------------------newtype Number a =-  Number (ReaderT Scientific (Except (Maybe Text)) a)-  deriving (Functor, Applicative, Alternative)--{-# INLINE scientific #-}-scientific :: Number Scientific-scientific = Number ask--{-# INLINE integer #-}-integer :: (Integral a, Bounded a) => Number a-integer = Number $ ReaderT $ \ x -> if Scientific.isInteger x-  then case Scientific.toBoundedInteger x of-    Just int -> return int-    Nothing -> throwError (Just (fromString ("Number " <> show x <> " is out of integer range")))-  else throwError (Just (fromString ("Number " <> show x <> " is not integer")))--{-# INLINE floating #-}-floating :: RealFloat a => Number a-floating = Number $ ReaderT $ \ a -> case Scientific.toBoundedRealFloat a of-  Right b -> return b-  Left c -> if c == 0-    then throwError (Just (fromString ("Number " <> show a <> " is too small")))-    else throwError (Just (fromString ("Number " <> show a <> " is too large")))--{-# INLINE matchedScientific #-}-matchedScientific :: (Scientific -> Either Text a) -> Number a-matchedScientific matcher = Number $ ReaderT $ except . left Just . matcher--{-# INLINE matchedInteger #-}-matchedInteger :: (Integral integer, Bounded integer) => (integer -> Either Text a) -> Number a-matchedInteger matcher = Number $ case integer of-  Number parser -> parser >>= either (throwError . Just) return . matcher--{-# INLINE matchedFloating #-}-matchedFloating :: RealFloat floating => (floating -> Either Text a) -> Number a-matchedFloating matcher = Number $ case floating of-  Number parser -> parser >>= either (throwError . Just) return . matcher----- * Object parsers----------------------------{-|-JSON `Aeson.Object` parser.--}-newtype Object a =-  Object (ReaderT (HashMap Text Aeson.Value) (ExceptT Error.Error (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 name fieldParser = Object $ ReaderT $ \ object -> case HashMap.lookup name object of-  Just value -> case run fieldParser value of-    Right parsedValue -> return parsedValue-    Left error -> lift $ throwE $ Error.named name error-  Nothing -> throwE (Error.Error (pure name) "Object contains no field with this name")--{-# INLINE oneOfFields #-}-oneOfFields :: [Text] -> Value a -> Object a-oneOfFields keys valueParser = asum (fmap (flip field valueParser) keys)--{-# INLINE fieldMap #-}-fieldMap :: (Eq a, Hashable a) => String a -> Value b -> Object (HashMap a b)-fieldMap keyParser fieldParser = Object $ ReaderT $ fmap HashMap.fromList . traverse mapping . HashMap.toList where-  mapping (keyText, ast) = -    case runString keyParser keyText of-      Right parsedKey -> case run fieldParser ast of-        Right parsedField -> return (parsedKey, parsedField)-        Left error -> lift (throwE (Error.named keyText error))-      Left error -> lift (throwE (maybe mempty Error.message error))--{-# INLINE foldlFields #-}-foldlFields :: (state -> key -> field -> state) -> state -> String key -> Value field -> Object state-foldlFields step state keyParser fieldParser = Object $ ReaderT $ \ object -> HashMap.foldlWithKey' newStep (pure state) object where-  newStep stateE key fieldAst = -    case runString keyParser key of-      Right !parsedKey -> case run fieldParser fieldAst of-        Right !parsedField -> do-          !state <- stateE-          return $ step state parsedKey parsedField-        Left error -> lift (throwE (Error.named key error))-      Left error -> lift (throwE (maybe mempty Error.message error))----- * Array parsers----------------------------{-|-JSON `Aeson.Array` parser.--}-newtype Array a =-  Array (ReaderT (Vector Aeson.Value) (ExceptT Error.Error (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 index elementParser = Array $ ReaderT $ \ array -> case array Vector.!? index of-  Just element -> case run elementParser element of-    Right result -> return result-    Left error -> lift $ throwE $ Error.indexed index error-  Nothing -> throwE $ Error.Error (pure (fromString (show index))) "Array contains no element by this index"--{-# INLINE elementVector #-}-elementVector :: Value a -> Array (Vector a)-elementVector elementParser = Array $ ReaderT $ \ arrayAst -> flip Vector.imapM arrayAst $ \ index ast -> case run elementParser ast of-  Right element -> return element-  Left error -> lift $ throwE $ Error.indexed index error--{-# INLINE foldlElements #-}-foldlElements :: (state -> Int -> element -> state) -> state -> Value element -> Array state-foldlElements step state elementParser = Array $ ReaderT $ Vector.ifoldM' newStep state where-  newStep state index ast = case run elementParser ast of-    Right element -> return $ step state index element-    Left error -> lift $ throwE $ Error.indexed index error--{-# INLINE foldrElements #-}-foldrElements :: (Int -> element -> state -> state) -> state -> Value element -> Array state-foldrElements step state elementParser = Array $ ReaderT $ Vector.ifoldrM newStep state where-  newStep index ast nextState = case run elementParser ast of-    Right element -> return $ step index element nextState-    Left error -> lift $ throwE $ Error.indexed index error

@@ -1,43 +0,0 @@-module Aeson.ValueParser.Error-where--import Aeson.ValueParser.Prelude-import qualified Data.Text as Text-import qualified Text.Builder as TextBuilder---data Error = Error [Text] {-^ Path -} Text {-^ Message -}--instance Semigroup Error where-  (<>) _ b = b--instance Monoid Error where-  mempty = Error [] ""-  mappend = (<>)--instance IsString Error where-  fromString = message . fromString--instance Show Error where-  show = Text.unpack . toText--{-# 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 []--toText :: Error -> Text-toText = TextBuilder.run . toTextBuilder--toTextBuilder :: Error -> TextBuilder.Builder-toTextBuilder (Error path message) =-  "AST parsing error at path " <>-  foldMap (\ x -> "/" <> TextBuilder.text x) path <> ": " <>-  TextBuilder.text message

@@ -1,114 +0,0 @@-module Aeson.ValueParser.Prelude-(-  module Exports,-  showText,-)-where----- base---------------------------import Control.Applicative as Exports-import Control.Arrow as Exports-import Control.Category as Exports-import Control.Concurrent as Exports-import Control.Exception as Exports-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-import Data.Bool as Exports-import Data.Char as Exports-import Data.Coerce as Exports-import Data.Complex as Exports-import Data.Data as Exports-import Data.Dynamic as Exports-import Data.Either as Exports-import Data.Fixed as Exports-import Data.Foldable as Exports hiding (toList)-import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports-import Data.Functor.Identity as Exports-import Data.Int as Exports-import Data.IORef as Exports-import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))-import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Last(..), First(..), (<>))-import Data.Ord as Exports-import Data.Proxy as Exports-import Data.Ratio as Exports-import Data.Semigroup as Exports-import Data.STRef as Exports-import Data.String as Exports-import Data.Traversable as Exports-import Data.Tuple as Exports-import Data.Unique as Exports-import Data.Version as Exports-import Data.Word as Exports-import Debug.Trace as Exports-import Foreign.ForeignPtr as Exports-import Foreign.Ptr as Exports-import Foreign.StablePtr as Exports-import Foreign.Storable as Exports hiding (sizeOf, alignment)-import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..))-import GHC.Generics as Exports (Generic)-import GHC.IO.Exception as Exports-import Numeric as Exports-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-import System.IO.Error as Exports-import System.IO.Unsafe as Exports-import System.Mem as Exports-import System.Mem.StableName as Exports-import System.Timeout as Exports-import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)-import Unsafe.Coerce as Exports---- transformers---------------------------import Control.Monad.Trans.Class as Exports-import Control.Monad.Trans.Except as Exports hiding (liftCatch, liftCallCC)-import Control.Monad.Trans.Maybe as Exports hiding (liftCatch, liftCallCC, liftListen, liftPass)-import Control.Monad.Trans.Reader as Exports hiding (liftCatch, liftCallCC)---- mtl---------------------------import Control.Monad.Error.Class as Exports hiding (Error)---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- text---------------------------import Data.Text as Exports (Text)---- unordered-containers---------------------------import Data.HashMap.Strict as Exports (HashMap)---- vector---------------------------import Data.Vector as Exports (Vector)---- scientific---------------------------import Data.Scientific as Exports (Scientific)---- hashable---------------------------import Data.Hashable as Exports (Hashable)---showText :: Show a => a -> Text-showText = fromString . show

@@ -1,11 +0,0 @@-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

@@ -0,0 +1,319 @@+{-+Parser DSL for the \"aeson\" model of JSON tree.++The general model of this DSL is about switching between contexts.+-}+module AesonValueParser+(+  Value,+  run,+  runWithTextError,+  Error.Error(..),+  -- * Value parsers+  object,+  array,+  null,+  nullable,+  nullableMonoid,+  string,+  number,+  bool,+  fromJSON,+  -- * String parsers+  String,+  text,+  matchedText,+  attoparsedText,+  megaparsedText,+  -- * Number parsers+  Number,+  scientific,+  integer,+  floating,+  matchedScientific,+  matchedInteger,+  matchedFloating,+  -- * Object parsers+  Object,+  field,+  oneOfFields,+  fieldMap,+  foldlFields,+  -- * Array parsers+  Array,+  element,+  elementVector,+  foldlElements,+  foldrElements,+)+where++import AesonValueParser.Prelude hiding (bool, null, String)+import qualified AesonValueParser.Error as Error+import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Text.Megaparsec as Megaparsec+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Scientific as Scientific+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as Vector+import qualified AesonValueParser.Vector as Vector+++-- * Value+-------------------------++{-|+JSON `Aeson.Value` AST parser.++Its `Alternative` instance implements the logic of choosing between the possible types of JSON values.+-}+newtype Value a =+  Value (ReaderT Aeson.Value (MaybeT (Either Error.Error)) a)+  deriving (Functor, Applicative)++{-|+Implements the logic of choosing between the possible types of JSON values.++If you have multiple parsers of the same type of JSON value composed,+only the leftmost will be affective.+The errors from deeper parsers do not trigger the alternation,+instead they get propagated to the top.+-}+instance Alternative Value where+  empty = Value $ ReaderT $ const $ MaybeT $ return Nothing+  (<|>) (Value leftParser) (Value rightParser) = Value (leftParser <|> rightParser)++{-# INLINE run #-}+run :: Value a -> Aeson.Value -> Either Error.Error a+run = \ (Value parser) value -> (=<<) (maybe (Left (typeError value)) Right) $ runMaybeT $ runReaderT parser value where+  typeError = \ case+    Aeson.Array _ -> "Unexpected type: array"+    Aeson.Object _ -> "Unexpected type: object"+    Aeson.String _ -> "Unexpected type: string"+    Aeson.Number _ -> "Unexpected type: number"+    Aeson.Bool _ -> "Unexpected type: bool"+    Aeson.Null -> "Unexpected type: null"++{-# INLINE runWithTextError #-}+runWithTextError :: Value a -> Aeson.Value -> Either Text a+runWithTextError parser = left Error.toText . run parser++runString :: String a -> Text -> Either (Maybe Text) a+runString (String a) b = runExcept (runReaderT a b)++-- ** Definitions+-------------------------++{-# INLINE array #-}+array :: Array a -> Value a+array (Array parser) = Value $ ReaderT $ \ case+  Aeson.Array x -> lift $ join $ runExcept $ runExceptT $ runReaderT parser x+  _ -> empty++{-# INLINE object #-}+object :: Object a -> Value a+object (Object parser) = Value $ ReaderT $ \ case+  Aeson.Object x -> lift $ join $ runExcept $ runExceptT $ runReaderT parser x+  _ -> empty++{-# INLINE null #-}+null :: Value ()+null = Value $ ReaderT $ \ case+  Aeson.Null -> pure ()+  _ -> empty++{-# INLINE nullable #-}+nullable :: Value a -> Value (Maybe a)+nullable (Value parser) = Value $ ReaderT $ \ case+  Aeson.Null -> pure Nothing+  x -> fmap Just (runReaderT parser x)++{-# INLINE nullableMonoid #-}+nullableMonoid :: Monoid a => Value a -> Value a+nullableMonoid (Value parser) = Value $ ReaderT $ \ case+  Aeson.Null -> pure mempty+  x -> runReaderT parser x++{-# INLINE string #-}+string :: String a -> Value a+string (String parser) = Value $ ReaderT $ \ case+  Aeson.String x -> lift $ left (Error.message . fromMaybe "No details") $ runExcept $ runReaderT parser x+  _ -> empty++{-# INLINE number #-}+number :: Number a -> Value a+number (Number parser) = Value $ ReaderT $ \ case+  Aeson.Number x -> lift $ left (Error.message . fromMaybe "No details") $ runExcept $ runReaderT parser x+  _ -> empty++{-# INLINE bool #-}+bool :: Value Bool+bool = Value $ ReaderT $ \ case+  Aeson.Bool x -> return x+  _ -> empty++{-# INLINE fromJSON #-}+fromJSON :: Aeson.FromJSON a => Value a+fromJSON = Value $ ReaderT $ Aeson.fromJSON >>> \ case+  Aeson.Success r -> return r+  Aeson.Error m -> lift $ Left $ fromString m+++-- * String parsers+-------------------------++newtype String a =+  String (ReaderT Text (Except (Maybe Text)) a)+  deriving (Functor, Applicative, Alternative)++{-# INLINE text #-}+text :: String Text+text = String ask++{-# INLINE matchedText #-}+matchedText :: (Text -> Either Text a) -> String a+matchedText parser = String $ ReaderT $ except . left Just . parser++{-# INLINE attoparsedText #-}+attoparsedText :: Attoparsec.Parser a -> String a+attoparsedText parser = matchedText $ left fromString . Attoparsec.parseOnly parser++{-# INLINE megaparsedText #-}+megaparsedText :: Megaparsec.Parsec Void Text a -> String a+megaparsedText = matchedText . matcher where+  matcher :: Megaparsec.Parsec Void Text a -> Text -> Either Text a+  matcher p = left (fromString . Megaparsec.errorBundlePretty) . Megaparsec.runParser (p <* Megaparsec.eof) ""+++-- * Number parsers+-------------------------++newtype Number a =+  Number (ReaderT Scientific (Except (Maybe Text)) a)+  deriving (Functor, Applicative, Alternative)++{-# INLINE scientific #-}+scientific :: Number Scientific+scientific = Number ask++{-# INLINE integer #-}+integer :: (Integral a, Bounded a) => Number a+integer = Number $ ReaderT $ \ x -> if Scientific.isInteger x+  then case Scientific.toBoundedInteger x of+    Just int -> return int+    Nothing -> throwError (Just (fromString ("Number " <> show x <> " is out of integer range")))+  else throwError (Just (fromString ("Number " <> show x <> " is not integer")))++{-# INLINE floating #-}+floating :: RealFloat a => Number a+floating = Number $ ReaderT $ \ a -> case Scientific.toBoundedRealFloat a of+  Right b -> return b+  Left c -> if c == 0+    then throwError (Just (fromString ("Number " <> show a <> " is too small")))+    else throwError (Just (fromString ("Number " <> show a <> " is too large")))++{-# INLINE matchedScientific #-}+matchedScientific :: (Scientific -> Either Text a) -> Number a+matchedScientific matcher = Number $ ReaderT $ except . left Just . matcher++{-# INLINE matchedInteger #-}+matchedInteger :: (Integral integer, Bounded integer) => (integer -> Either Text a) -> Number a+matchedInteger matcher = Number $ case integer of+  Number parser -> parser >>= either (throwError . Just) return . matcher++{-# INLINE matchedFloating #-}+matchedFloating :: RealFloat floating => (floating -> Either Text a) -> Number a+matchedFloating matcher = Number $ case floating of+  Number parser -> parser >>= either (throwError . Just) return . matcher+++-- * Object parsers+-------------------------++{-|+JSON `Aeson.Object` parser.+-}+newtype Object a =+  Object (ReaderT (HashMap Text Aeson.Value) (ExceptT Error.Error (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 name fieldParser = Object $ ReaderT $ \ object -> case HashMap.lookup name object of+  Just value -> case run fieldParser value of+    Right parsedValue -> return parsedValue+    Left error -> lift $ throwE $ Error.named name error+  Nothing -> throwE (Error.Error (pure name) "Object contains no field with this name")++{-# INLINE oneOfFields #-}+oneOfFields :: [Text] -> Value a -> Object a+oneOfFields keys valueParser = asum (fmap (flip field valueParser) keys)++{-# INLINE fieldMap #-}+fieldMap :: (Eq a, Hashable a) => String a -> Value b -> Object (HashMap a b)+fieldMap keyParser fieldParser = Object $ ReaderT $ fmap HashMap.fromList . traverse mapping . HashMap.toList where+  mapping (keyText, ast) = +    case runString keyParser keyText of+      Right parsedKey -> case run fieldParser ast of+        Right parsedField -> return (parsedKey, parsedField)+        Left error -> lift (throwE (Error.named keyText error))+      Left error -> lift (throwE (maybe mempty Error.message error))++{-# INLINE foldlFields #-}+foldlFields :: (state -> key -> field -> state) -> state -> String key -> Value field -> Object state+foldlFields step state keyParser fieldParser = Object $ ReaderT $ \ object -> HashMap.foldlWithKey' newStep (pure state) object where+  newStep stateE key fieldAst = +    case runString keyParser key of+      Right !parsedKey -> case run fieldParser fieldAst of+        Right !parsedField -> do+          !state <- stateE+          return $ step state parsedKey parsedField+        Left error -> lift (throwE (Error.named key error))+      Left error -> lift (throwE (maybe mempty Error.message error))+++-- * Array parsers+-------------------------++{-|+JSON `Aeson.Array` parser.+-}+newtype Array a =+  Array (ReaderT (Vector Aeson.Value) (ExceptT Error.Error (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 index elementParser = Array $ ReaderT $ \ array -> case array Vector.!? index of+  Just element -> case run elementParser element of+    Right result -> return result+    Left error -> lift $ throwE $ Error.indexed index error+  Nothing -> throwE $ Error.Error (pure (fromString (show index))) "Array contains no element by this index"++{-# INLINE elementVector #-}+elementVector :: Value a -> Array (Vector a)+elementVector elementParser = Array $ ReaderT $ \ arrayAst -> flip Vector.imapM arrayAst $ \ index ast -> case run elementParser ast of+  Right element -> return element+  Left error -> lift $ throwE $ Error.indexed index error++{-# INLINE foldlElements #-}+foldlElements :: (state -> Int -> element -> state) -> state -> Value element -> Array state+foldlElements step state elementParser = Array $ ReaderT $ Vector.ifoldM' newStep state where+  newStep state index ast = case run elementParser ast of+    Right element -> return $ step state index element+    Left error -> lift $ throwE $ Error.indexed index error++{-# INLINE foldrElements #-}+foldrElements :: (Int -> element -> state -> state) -> state -> Value element -> Array state+foldrElements step state elementParser = Array $ ReaderT $ Vector.ifoldrM newStep state where+  newStep index ast nextState = case run elementParser ast of+    Right element -> return $ step index element nextState+    Left error -> lift $ throwE $ Error.indexed index error

@@ -0,0 +1,43 @@+module AesonValueParser.Error+where++import AesonValueParser.Prelude+import qualified Data.Text as Text+import qualified Text.Builder as TextBuilder+++data Error = Error [Text] {-^ Path -} Text {-^ Message -}++instance Semigroup Error where+  (<>) _ b = b++instance Monoid Error where+  mempty = Error [] ""+  mappend = (<>)++instance IsString Error where+  fromString = message . fromString++instance Show Error where+  show = Text.unpack . toText++{-# 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 []++toText :: Error -> Text+toText = TextBuilder.run . toTextBuilder++toTextBuilder :: Error -> TextBuilder.Builder+toTextBuilder (Error path message) =+  "AST parsing error at path " <>+  foldMap (\ x -> "/" <> TextBuilder.text x) path <> ": " <>+  TextBuilder.text message

@@ -0,0 +1,115 @@+module AesonValueParser.Prelude+(+  module Exports,+  showText,+)+where+++-- base+-------------------------+import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+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+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Identity as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.Semigroup as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (sizeOf, alignment)+import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..))+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+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+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports++-- transformers+-------------------------+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Except as Exports hiding (liftCatch, liftCallCC)+import Control.Monad.Trans.Maybe as Exports hiding (liftCatch, liftCallCC, liftListen, liftPass)+import Control.Monad.Trans.Reader as Exports hiding (liftCatch, liftCallCC)++-- mtl+-------------------------+import Control.Monad.Error.Class as Exports hiding (Error)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- unordered-containers+-------------------------+import Data.HashMap.Strict as Exports (HashMap)++-- vector+-------------------------+import Data.Vector as Exports (Vector)++-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)++-- hashable+-------------------------+import Data.Hashable as Exports (Hashable)+++showText :: Show a => a -> Text+showText = fromString . show

@@ -0,0 +1,11 @@+module AesonValueParser.Vector+where++import AesonValueParser.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