AccParser newtype with accumulating Applicative instance

Author: bergmark

Data/Aeson/AccParser.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.AccParser
+  (
+    AccParser (AccParser, getParser)
+  , accSequence
+  , accTraverse
+  , (<*>+)
+  ) where
+
+import Data.Aeson.Types.Internal (Parser (..), runParser)
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+
+newtype AccParser a = AccParser { getParser :: Parser a }
+    deriving Functor
+
+instance Applicative AccParser where
+    pure = AccParser . pure
+    f <*> a = AccParser (getParser f <*>+ getParser a)
+
+-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
+-- from both subparsers.
+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
+liftP2 f pa pb = Parser $ \path kf ks ->
+  runParser pa path
+    (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
+    (\a -> runParser pb path kf (\b -> ks (f a b)))
+{-# INLINE liftP2 #-}
+
+accSequence :: Traversable t => t (Parser a) -> Parser (t a)
+accSequence = accTraverse id
+
+accTraverse :: Traversable t => (a -> Parser b) -> t a -> Parser (t b)
+accTraverse f s = getParser $ traverse' (AccParser . f) s
+
+-- Making sure we are using Applicative AccParser
+traverse' :: Traversable t => (a -> AccParser b) -> t a -> AccParser (t b)
+traverse' = traverse
+
+infixl 4 <*>+
+
+-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
+(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
+(<*>+) = liftP2 id
+{-# INLINE (<*>+) #-}

Data/Aeson/Types.hs

@@ -35,8 +35,6 @@ module Data.Aeson.Types
     , parseMaybe
     , ToJSON(..)
     , KeyValue(..)
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError

Data/Aeson/Types/FromJSON.hs

@@ -86,6 +86,7 @@ import Data.Aeson.Internal.Functions (mapKey)
 import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
+import Data.Aeson.AccParser
 import Data.Attoparsec.Number (Number(..))
 import Data.Bits (unsafeShiftR)
 import Data.Fixed (Fixed, HasResolution)
@@ -606,7 +607,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
 
 -- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
 listParser :: (Value -> Parser a) -> Value -> Parser [a]
-listParser f (Array xs) = fmap V.toList (accumulateTraverseVector f xs)
+listParser f (Array xs) = getParser $ V.toList <$> traverse (AccParser . f) xs
 listParser _ v          = typeMismatch "[a]" v
 {-# INLINE listParser #-}
 
@@ -1529,7 +1530,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
 instance FromJSON1 Seq.Seq where
     liftParseJSON p _ = withArray "Seq a" $
       fmap Seq.fromList .
-      accumulateSequenceList . zipWith (parseIndexedJSON p) [0..] . V.toList
+      accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -1607,7 +1608,7 @@ instance FromJSONKey UUID.UUID where
 
 instance FromJSON1 Vector where
     liftParseJSON p _ = withArray "Vector a" $
-        accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed
+        accTraverse (uncurry $ parseIndexedJSON p) . V.indexed
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where

Data/Aeson/Types/Internal.hs

@@ -25,20 +25,18 @@
 
 module Data.Aeson.Types.Internal
     (
-      accumulateSequenceList
-    , accumulateTraverseList
-    , accumulateTraverseVector
 
     -- * Core JSON types
-    , Value(..)
+      Value(..)
     , Array
     , emptyArray, isEmptyArray
     , Pair
     , Object
     , emptyObject
 
     -- * Type conversion
-    , Parser
+    , Parser (Parser)
+    , runParser
     , Result(..)
     , IResult(..)
     , JSONPathElement(..)
@@ -47,8 +45,6 @@ module Data.Aeson.Types.Internal
     , parse
     , parseEither
     , parseMaybe
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
@@ -344,36 +340,6 @@ apP d e = do
   return (b a)
 {-# INLINE apP #-}
 
--- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
--- from both subparsers.
-liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
-liftP2 f pa pb = Parser $ \path kf ks ->
-  runParser pa path
-    (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
-    (\a -> runParser pb path kf (\b -> ks (f a b)))
-{-# INLINE liftP2 #-}
-
-accumulateSequenceList :: [Parser a] -> Parser [a]
-accumulateSequenceList = accumulateTraverseList id
-
-accumulateTraverseList :: (a -> Parser b) -> [a] -> Parser [b]
-accumulateTraverseList f s = case s of
-  []    -> pure mempty
-  h : t -> (:) <$> (f h) <*>+ (accumulateTraverseList f t)
-
-accumulateTraverseVector :: (a -> Parser b) -> Vector a -> Parser (Vector b)
-accumulateTraverseVector f v =
-    if V.null v
-        then pure mempty
-        else V.cons <$> (f $ V.head v) <*>+ (accumulateTraverseVector f $ V.tail v)
-
-infixl 4 <*>+
-
--- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
-(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
-(<*>+) = liftP2 id
-{-# INLINE (<*>+) #-}
-
 -- | A JSON \"object\" (key\/value map).
 type Object = HashMap Text Value
 

aeson.cabal

@@ -84,6 +84,7 @@ library
 
   exposed-modules:
     Data.Aeson
+    Data.Aeson.AccParser
     Data.Aeson.Encoding
     Data.Aeson.Parser
     Data.Aeson.Text
@@ -213,7 +214,7 @@ test-suite tests
     directory,
     dlist,
     filepath,
-    generic-deriving >= 1.10 && < 1.12,
+    generic-deriving >= 1.10 && < 1.13,
     ghc-prim >= 0.2,
     hashable >= 1.2.4.0,
     scientific,

stack-lts10.yaml

@@ -0,0 +1,9 @@
+resolver: lts-10.0
+packages:
+- '.'
+flags:
+  aeson:
+    fast: true
+    cffi: false
+  attoparsec-iso8601:
+    fast: true