aeson-value-parser 0.12.4 → 0.19.7.2
raw patch · 7 files changed
Files
- Setup.hs +0/−2
- aeson-value-parser.cabal +78/−52
- library/Aeson/ValueParser.hs +0/−243
- library/AesonValueParser.hs +408/−0
- library/AesonValueParser/Error.hs +43/−0
- library/AesonValueParser/Prelude.hs +85/−0
- library/AesonValueParser/Vector.hs +9/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
aeson-value-parser.cabal view
@@ -1,59 +1,85 @@-name:- aeson-value-parser-version:- 0.12.4-synopsis:- An API for parsing "aeson" JSON tree into Haskell types+cabal-version: 3.0+name: aeson-value-parser+version: 0.19.7.2+synopsis: API for parsing "aeson" JSON tree into Haskell types description:-category:- Data, JSON, Parsing-homepage:- https://github.com/sannsyn/aeson-value-parser-bug-reports:- https://github.com/sannsyn/aeson-value-parser/issues-author:- Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:- Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:- (c) 2015, Sannsyn AS-license:- MIT-license-file:- LICENSE-build-type:- Simple-cabal-version:- >=1.10+ A flexible parser DSL of JSON AST produced by the \"aeson\" library+ with automated and highly detailed error reporting.+ Provides a featureful toolkit for parsing real-world documents with schemas+ of any complexity or ambiguity, which the "FromJSON" instances+ are simply not fit for. +category: Data, JSON, Parsing+homepage: https://github.com/sannsyn/aeson-value-parser+bug-reports: https://github.com/sannsyn/aeson-value-parser/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2015, Sannsyn AS+license: MIT+license-file: LICENSE+ source-repository head- type:- git- location:- git://github.com/sannsyn/aeson-value-parser.git+ type: git+ location: git://github.com/sannsyn/aeson-value-parser.git library- hs-source-dirs:- library+ hs-source-dirs: library default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010- exposed-modules:- Aeson.ValueParser+ NoImplicitPrelude+ NoMonomorphismRestriction+ Arrows+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ LiberalTypeSynonyms+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ ParallelListComp+ PatternGuards+ PatternSynonyms+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeFamilies+ TypeOperators+ UnboxedTuples++ default-language: Haskell2010+ exposed-modules: AesonValueParser+ other-modules:+ AesonValueParser.Error+ AesonValueParser.Prelude+ AesonValueParser.Vector+ build-depends:- --- aeson ==1.*,- json-pointer ==0.1.*,- json-pointer-aeson ==0.1.*,- --- unordered-containers ==0.2.*,- vector >=0.10 && <0.13,- scientific ==0.3.*,- text ==1.*,- bytestring >=0.10 && <0.12,- --- foldl >=1.3 && <2,- transformers >=0.5 && <0.7,- mtl-prelude <3,- base-prelude >=0.1.19 && <2+ , aeson >=2.0.2 && <3+ , attoparsec >=0.14 && <0.15+ , base >=4.12 && <5+ , bytestring >=0.10 && <0.13+ , hashable >=1.4 && <2+ , megaparsec >=8 && <10+ , mtl >=2.2 && <3+ , scientific >=0.3 && <0.4+ , text >=1 && <3+ , transformers >=0.5 && <0.7+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.14
− library/Aeson/ValueParser.hs
@@ -1,243 +0,0 @@--- |--- A parser DSL for the \"aeson\" model of the JSON tree.-module Aeson.ValueParser-(- Value,- run,- -- * Value parsers- object,- array,- null,- nullable,- string,- stringAsBytes,- number,- numberAsInt,- bool,- fromJSON,- pointed,- -- * Object parsers- Object,- field,- fieldsMap,- foldFields,- foldlFields,- -- * Array parsers- Array,- element,- elementsVector,- foldElements,- foldlElements,- foldlElements1,- foldrElements,-)-where--import BasePrelude hiding (bool, null)-import MTLPrelude-import Data.Text (Text)-import Data.Scientific (Scientific)-import Data.ByteString (ByteString)-import Control.Foldl (Fold(..))-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----- |--- A JSON 'A.Value' parser.-newtype Value a =- Value (ReaderT A.Value (Except Text) a)- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)--{-# INLINE run #-}-run :: Value a -> A.Value -> Either Text a-run (Value effect) =- runExcept . runReaderT effect---- * Value parsers----------------------------{-# INLINE aesonMatcher #-}-aesonMatcher :: (A.Value -> Either Text a) -> Value a-aesonMatcher matcher =- Value $ ReaderT $ either (except . Left) pure . 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"--{-# INLINE object #-}-object :: Object a -> Value a-object (Object effect) =- Value $ ReaderT $ \case- A.Object x ->- runReaderT effect x- _ ->- (except . Left) "Not an object"--{-# INLINE null #-}-null :: Value ()-null =- aesonMatcher $ \case- A.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)--{-# INLINE string #-}-string :: Value Text-string =- aesonMatcher $ \case- A.String t ->- pure t- _ ->- Left "Not a string"--{-# INLINE stringAsBytes #-}-stringAsBytes :: Value ByteString-stringAsBytes =- F.encodeUtf8 <$> string--{-# INLINE number #-}-number :: Value Scientific-number =- aesonMatcher $ \case- A.Number x ->- pure x- _ ->- Left "Not a number"--{-# INLINE numberAsInt #-}-numberAsInt :: Value Int-numberAsInt =- round <$> number--{-# INLINE bool #-}-bool :: Value Bool-bool =- aesonMatcher $ \case- A.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----- * Object parsers------------------------------ |--- A JSON 'A.Object' parser.-newtype Object a =- Object (ReaderT A.Object (Except Text) a)- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)--{-# 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 fieldsMap #-}-fieldsMap :: Value a -> Object (B.HashMap Text a)-fieldsMap (Value effect) =- Object $ ReaderT $ mapM (runReaderT effect)--{-# INLINE foldFields #-}-foldFields :: Fold (Text, field) object -> Value field -> Object object-foldFields (Fold foldStep foldInit foldEnd) value =- fmap foldEnd (foldlFields foldStep foldInit value)--{-# 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)----- * Array parsers------------------------------ |--- A JSON 'A.Array' parser.-newtype Array a =- Array (ReaderT A.Array (Except Text) a)- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)--{-# 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)--{-# INLINE foldElements #-}-foldElements :: Fold element array -> Value element -> Array array-foldElements (Fold foldStep foldInit foldEnd) value =- fmap foldEnd (foldlElements foldStep foldInit value)--{-# 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)--{-# 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
+ library/AesonValueParser.hs view
@@ -0,0 +1,408 @@+{-+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,+ runAsValueParser,+ Error.Error (..),+ parseByteString,++ -- * Value parsers+ object,+ array,+ null,+ nullable,+ nullableMonoid,+ string,+ number,+ bool,+ fromJSON,++ -- * String parsers+ String,+ text,+ mappedText,+ narrowedText,+ matchedText,+ attoparsedText,+ megaparsedText,++ -- * Number parsers+ Number,+ scientific,+ integer,+ floating,+ matchedScientific,+ matchedInteger,+ matchedFloating,++ -- * Object parsers+ Object,+ field,+ oneOfFields,+ fieldMap,+ foldlFields,+ fieldsAmount,++ -- * Array parsers+ Array,+ element,+ elementVector,+ elementList,+ foldlElements,+ foldrElements,+ elementsAmount,+ )+where++import qualified AesonValueParser.Error as Error+import AesonValueParser.Prelude hiding (String, bool, null)+import qualified AesonValueParser.Vector as Vector+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Types as Aeson+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Text.Megaparsec as Megaparsec++-- * 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++-- | Convert into a function directly applicable as definition+-- of 'Aeson.parseJSON'.+--+-- Here's an example of how it can be used:+--+-- @+-- data Artist = Artist+-- { artistName :: Text,+-- artistGenres :: [Text]+-- }+--+-- instance 'Aeson.FromJSON' Artist where+-- 'Aeson.parseJSON' = 'runAsValueParser' $+-- 'object' $ do+-- name <- 'field' "name" $ 'string' 'text'+-- genres <- 'field' "genres" $ 'array' $ 'elementList' $ 'string' 'text'+-- return $ Artist name genres+-- @+runAsValueParser :: Value a -> Aeson.Value -> Aeson.Parser a+runAsValueParser parser =+ either (fail . Text.unpack) return+ . runWithTextError parser++runString :: String a -> Text -> Either (Maybe Text) a+runString (String a) b = first getLast (runExcept (runReaderT a b))++parseByteString :: Value a -> ByteString -> Either Text a+parseByteString p bs =+ case Aeson.eitherDecodeStrict' bs of+ Right aeson -> runWithTextError p aeson+ Left stringErr -> Left (fromString stringErr)++-- ** 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" . getLast) $ 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" . getLast) $ 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 (Last Text)) a)+ deriving (Functor, Applicative, Alternative)++{-# INLINE text #-}+text :: String Text+text = String ask++{-# INLINE mappedText #-}+mappedText :: [(Text, a)] -> String a+mappedText mappingList =+ let expectedValuesText = fromString (show (fmap fst mappingList))+ match lookup text = case lookup text of+ Just a -> Right a+ _ -> Left ("Unexpected value: \"" <> text <> "\". Expecting one of: " <> expectedValuesText)+ mappingListLength = length mappingList+ in if mappingListLength > 512+ then+ let !hashMap = HashMap.fromList mappingList+ in matchedText (match (flip HashMap.lookup hashMap))+ else matchedText (match (flip lookup mappingList))++{-# INLINE narrowedText #-}+narrowedText :: (Text -> Maybe a) -> String a+narrowedText narrow = matchedText match+ where+ match text = case narrow text of+ Just a -> Right a+ _ -> Left ("Unexpected value: \"" <> text <> "\"")++{-# INLINE matchedText #-}+matchedText :: (Text -> Either Text a) -> String a+matchedText parser = String $ ReaderT $ except . left (Last . 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 (Last 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 (Last (Just (fromString ("Number " <> show x <> " is out of integer range"))))+ else throwError (Last (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 (Last (Just (fromString ("Number " <> show a <> " is too small"))))+ else throwError (Last (Just (fromString ("Number " <> show a <> " is too large"))))++{-# INLINE matchedScientific #-}+matchedScientific :: (Scientific -> Either Text a) -> Number a+matchedScientific matcher = Number $ ReaderT $ except . left (Last . 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 . Last . 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 . Last . Just) return . matcher++-- * Object parsers++-- |+-- JSON `Aeson.Object` parser.+newtype Object a+ = Object (ReaderT (KeyMap.KeyMap 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 KeyMap.lookup (Key.fromText 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) message)+ where+ message =+ "Object contains no field with this name. Fields available: "+ <> fromString (show (KeyMap.keys object))++{-# INLINE oneOfFields #-}+oneOfFields :: [Text] -> Value a -> Object a+oneOfFields keys valueParser = asum (fmap (flip field valueParser) keys)++{-# INLINE fieldMap #-}+fieldMap :: (Hashable a) => String a -> Value b -> Object (HashMap a b)+fieldMap keyParser fieldParser = Object $ ReaderT $ fmap HashMap.fromList . traverse mapping . KeyMap.toList+ where+ mapping (key, ast) =+ case Key.toText key of+ keyText -> 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 ->+ KeyMap.foldrWithKey newStep pure object state+ where+ newStep key value next !state =+ case Key.toText key of+ key -> case runString keyParser key of+ Right parsedKey -> case run fieldParser value of+ Right parsedValue -> next (step state parsedKey parsedValue)+ Left error -> lift $ throwE $ Error.named key error+ Left error -> lift (throwE (maybe mempty Error.message error))++fieldsAmount :: Object Int+fieldsAmount = Object $ ReaderT $ pure . KeyMap.size++-- * 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 elementList #-}+elementList :: Value a -> Array [a]+elementList = fmap Vector.toList . elementVector++{-# 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++elementsAmount :: Array Int+elementsAmount = Array $ ReaderT $ pure . Vector.length
+ library/AesonValueParser/Error.hs view
@@ -0,0 +1,43 @@+module AesonValueParser.Error where++import AesonValueParser.Prelude+import qualified Data.Text as Text++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 (Error path message) =+ "AST parsing error at path "+ <> foldMap (\x -> "/" <> x) path+ <> ": "+ <> message
+ library/AesonValueParser/Prelude.hs view
@@ -0,0 +1,85 @@+module AesonValueParser.Prelude+ ( module Exports,+ showText,+ )+where++import Control.Applicative as Exports+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Error.Class as Exports (MonadError (catchError, throwError), liftEither)+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Except as Exports hiding (liftCallCC)+import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+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 hiding (unzip)+import Data.Functor.Identity as Exports+import Data.HashMap.Strict as Exports (HashMap)+import Data.Hashable as Exports (Hashable)+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding ((<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.Scientific as Exports (Scientific)+import Data.Semigroup as Exports hiding (First (..), Last (..))+import Data.String as Exports+import Data.Text as Exports (Text)+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Vector as Exports (Vector)+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 (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+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.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))++showText :: (Show a) => a -> Text+showText = fromString . show
+ library/AesonValueParser/Vector.hs view
@@ -0,0 +1,9 @@+module AesonValueParser.Vector where++import AesonValueParser.Prelude hiding (Vector)+import qualified Data.Vector.Fusion.Bundle.Monadic as BundleM+import Data.Vector.Generic++{-# 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