git.iko.soy/typeable/aeson
on master help sign in
AccParser newtype with accumulating Applicative instance
commit9eef7e7425a1367389f4feaa1d7ad8e7ead4674c authorAdam Bergmark <adam@bergmark.nl> dateSat 23 Dec 2017, 15:57 (9 years ago) parentabdb8a3
5 files changed+54−43
compare with master
unifiedsplit
Data/Aeson/AccParser.hs+46 Data/Aeson/Types.hs−2 Data/Aeson/Types/FromJSON.hs+4−3 Data/Aeson/Types/Internal.hs+3−38 aeson.cabal+1
Data/Aeson/AccParser.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+module Data.Aeson.AccParser
4+ (
5+ AccParser (AccParser, getParser)
6+ , accSequence
7+ , accTraverse
8+ , (<*>+)
9+ ) where
10+
11+import Data.Aeson.Types.Internal (Parser (..), runParser)
12+import Data.List.NonEmpty (NonEmpty ((:|)))
13+import qualified Data.List.NonEmpty as NonEmpty
14+
15+newtype AccParser a = AccParser { getParser :: Parser a }
16+ deriving Functor
17+
18+instance Applicative AccParser where
19+ pure = AccParser . pure
20+ f <*> a = AccParser (getParser f <*>+ getParser a)
21+
22+-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
23+-- from both subparsers.
24+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
25+liftP2 f pa pb = Parser $ \path kf ks ->
26+ runParser pa path
27+ (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
28+ (\a -> runParser pb path kf (\b -> ks (f a b)))
29+{-# INLINE liftP2 #-}
30+
31+accSequence :: Traversable t => t (Parser a) -> Parser (t a)
32+accSequence = accTraverse id
33+
34+accTraverse :: Traversable t => (a -> Parser b) -> t a -> Parser (t b)
35+accTraverse f s = getParser $ traverse' (AccParser . f) s
36+
37+-- Making sure we are using Applicative AccParser
38+traverse' :: Traversable t => (a -> AccParser b) -> t a -> AccParser (t b)
39+traverse' = traverse
40+
41+infixl 4 <*>+
42+
43+-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
44+(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
45+(<*>+) = liftP2 id
46+{-# INLINE (<*>+) #-}
Data/Aeson/Types.hs−2
@@ -35,8 +35,6 @@ module Data.Aeson.Types
3535 , parseMaybe
3636 , ToJSON(..)
3737 , KeyValue(..)
38− , liftP2
39− , (<*>+)
4038 , modifyFailure
4139 , parserThrowError
4240 , parserCatchError
Data/Aeson/Types/FromJSON.hs+4−3
@@ -86,6 +86,7 @@ import Data.Aeson.Internal.Functions (mapKey)
8686import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
8787import Data.Aeson.Types.Generic
8888import Data.Aeson.Types.Internal
89+import Data.Aeson.AccParser
8990import Data.Attoparsec.Number (Number(..))
9091import Data.Bits (unsafeShiftR)
9192import Data.Fixed (Fixed, HasResolution)
@@ -606,7 +607,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
606607
607608-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
608609listParser :: (Value -> Parser a) -> Value -> Parser [a]
609−listParser f (Array xs) = fmap V.toList (accumulateTraverseVector f xs)
610+listParser f (Array xs) = getParser $ V.toList <$> traverse (AccParser . f) xs
610611listParser _ v = typeMismatch "[a]" v
611612{-# INLINE listParser #-}
612613
@@ -1529,7 +1530,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
15291530instance FromJSON1 Seq.Seq where
15301531 liftParseJSON p _ = withArray "Seq a" $
15311532 fmap Seq.fromList .
1532− accumulateSequenceList . zipWith (parseIndexedJSON p) [0..] . V.toList
1533+ accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList
15331534 {-# INLINE liftParseJSON #-}
15341535
15351536instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -1607,7 +1608,7 @@ instance FromJSONKey UUID.UUID where
16071608
16081609instance FromJSON1 Vector where
16091610 liftParseJSON p _ = withArray "Vector a" $
1610− accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed
1611+ accTraverse (uncurry $ parseIndexedJSON p) . V.indexed
16111612 {-# INLINE liftParseJSON #-}
16121613
16131614instance (FromJSON a) => FromJSON (Vector a) where
Data/Aeson/Types/Internal.hs+3−38
@@ -25,12 +25,8 @@
2525
2626module Data.Aeson.Types.Internal
2727 (
28− accumulateSequenceList
29− , accumulateTraverseList
30− , accumulateTraverseVector
31−
3228 -- * Core JSON types
33− , Value(..)
29+ Value(..)
3430 , Array
3531 , emptyArray, isEmptyArray
3632 , Pair
@@ -38,7 +34,8 @@ module Data.Aeson.Types.Internal
3834 , emptyObject
3935
4036 -- * Type conversion
41− , Parser
37+ , Parser (Parser)
38+ , runParser
4239 , Result(..)
4340 , IResult(..)
4441 , JSONPathElement(..)
@@ -47,8 +44,6 @@ module Data.Aeson.Types.Internal
4744 , parse
4845 , parseEither
4946 , parseMaybe
50− , liftP2
51− , (<*>+)
5247 , modifyFailure
5348 , parserThrowError
5449 , parserCatchError
@@ -344,36 +339,6 @@ apP d e = do
344339 return (b a)
345340{-# INLINE apP #-}
346341
347−-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
348−-- from both subparsers.
349−liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
350−liftP2 f pa pb = Parser $ \path kf ks ->
351− runParser pa path
352− (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
353− (\a -> runParser pb path kf (\b -> ks (f a b)))
354−{-# INLINE liftP2 #-}
355−
356−accumulateSequenceList :: [Parser a] -> Parser [a]
357−accumulateSequenceList = accumulateTraverseList id
358−
359−accumulateTraverseList :: (a -> Parser b) -> [a] -> Parser [b]
360−accumulateTraverseList f s = case s of
361− [] -> pure mempty
362− h : t -> (:) <$> (f h) <*>+ (accumulateTraverseList f t)
363−
364−accumulateTraverseVector :: (a -> Parser b) -> Vector a -> Parser (Vector b)
365−accumulateTraverseVector f v =
366− if V.null v
367− then pure mempty
368− else V.cons <$> (f $ V.head v) <*>+ (accumulateTraverseVector f $ V.tail v)
369−
370−infixl 4 <*>+
371−
372−-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
373−(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
374−(<*>+) = liftP2 id
375−{-# INLINE (<*>+) #-}
376−
377342-- | A JSON \"object\" (key\/value map).
378343type Object = HashMap Text Value
379344
aeson.cabal+1
@@ -84,6 +84,7 @@ library
8484
8585 exposed-modules:
8686 Data.Aeson
87+ Data.Aeson.AccParser
8788 Data.Aeson.Encoding
8889 Data.Aeson.Parser
8990 Data.Aeson.Text