Higherkinded special strings

Data/Aeson/Encode/Functions.hs

@@ -4,6 +4,7 @@ module Data.Aeson.Encode.Functions
     (
       brackets
     , builder
+    , builder'
     , char7
     , encode
     , foldable
@@ -26,10 +27,18 @@ import Data.Foldable (Foldable, foldMap)
 import Data.Monoid (mempty)
 #endif
 
+list :: (a -> Encoding) -> [a] -> Encoding
+list = listEncoding
+
 builder :: ToJSON a => a -> Builder
 builder = fromEncoding . toEncoding
 {-# INLINE builder #-}
 
+builder' :: (a -> Encoding) -> a -> Builder
+builder' f = fromEncoding . f
+{-# INLINE builder' #-}
+
+
 -- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
 --
 -- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.
@@ -38,17 +47,10 @@ encode = B.toLazyByteString . builder
 {-# INLINE encode #-}
 
 -- | Encode a 'Foldable' as a JSON array.
-foldable :: (Foldable t, ToJSON a) => t a -> Encoding
-foldable = brackets '[' ']' . foldMap (Value . toEncoding)
+foldable :: (Foldable t) => (a -> Encoding) -> t a -> Encoding
+foldable to = brackets '[' ']' . foldMap (Value . to)
 {-# INLINE foldable #-}
 
-list :: (ToJSON a) => [a] -> Encoding
-list []     = emptyArray_
-list (x:xs) = Encoding $
-              char7 '[' <> builder x <> commas xs <> char7 ']'
-      where commas = foldr (\v vs -> char7 ',' <> builder v <> vs) mempty
-{-# INLINE list #-}
-
 list' :: (a -> Encoding) -> [a] -> Encoding
 list' _ []     = emptyArray_
 list' e (x:xs) = Encoding $

Data/Aeson/Types.hs

@@ -37,6 +37,17 @@ module Data.Aeson.Types
     , KeyValue(..)
     , modifyFailure
 
+    -- ** Liftings to unary and binary type constructors
+    , FromJSON1(..)
+    , parseJSON1
+    , FromJSON2(..)
+    , parseJSON2
+    , ToJSON1(..)
+    , toJSON1
+    , toEncoding1
+    , ToJSON2(..)
+    , toJSON2
+
     -- ** Keys for maps
     , ToJSONKey(..)
     , ToJSONKeyFunction(..)

Data/Aeson/Types/Class.hs

@@ -17,6 +17,17 @@ module Data.Aeson.Types.Class
     -- * Core JSON classes
       FromJSON(..)
     , ToJSON(..)
+    -- * Liftings to unary and binary type constructors
+    , FromJSON1(..)
+    , parseJSON1
+    , FromJSON2(..)
+    , parseJSON2
+    , ToJSON1(..)
+    , toJSON1
+    , toEncoding1
+    , ToJSON2(..)
+    , toJSON2
+    , toEncoding2
     -- * Generic JSON classes
     , GFromJSON(..)
     , GToJSON(..)
@@ -33,9 +44,15 @@ module Data.Aeson.Types.Class
     , KeyValue(..)
     -- * Functions needed for documentation
     , typeMismatch
+    -- * Encoding functions
+    , listEncoding
+    , listValue
+    , listParser
     ) where
 
+import Data.Aeson.Encode.Builder
 import Data.Aeson.Types.Internal
+import Data.Monoid ((<>))
 import Data.Text (Text)
 import GHC.Generics (Generic, Rep, from, to)
 import Data.Monoid ((<>))
@@ -44,6 +61,10 @@ import qualified Data.ByteString.Builder as B
 import qualified Data.Aeson.Encode.Builder as E
 import qualified Data.Vector as V
 
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid (mempty)
+#endif
+
 -- Coercible derivations aren't as powerful on GHC 7.8, though supported.
 #define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 709)
 
@@ -188,6 +209,19 @@ class ToJSON a where
     toEncoding = Encoding . E.encodeToBuilder . toJSON
     {-# INLINE toEncoding #-}
 
+    toJSONList :: [a] -> Value
+    toJSONList = listValue toJSON
+    {-# INLINE toJSONList #-}
+
+    toEncodingList :: [a] -> Encoding
+    toEncodingList [] = emptyArray_
+    toEncodingList (x:xs) = Encoding $
+        B.char7 '[' <> builder x <> commas xs <> B.char7 ']'
+      where
+        commas  = foldr (\v vs -> B.char7 ',' <> builder v <> vs) mempty
+        builder = fromEncoding . toEncoding
+    {-# INLINE toEncodingList #-}
+
 -- | A type that can be converted from JSON, with the possibility of
 -- failure.
 --
@@ -268,6 +302,19 @@ class FromJSON a where
     default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
     parseJSON = genericParseJSON defaultOptions
 
+    parseJSONList :: Value -> Parser [a]
+    parseJSONList (Array a)
+        = sequence
+        . zipWith parseIndexedJSON [0..]
+        . V.toList
+        $ a
+      where
+        parseIndexedJSON :: FromJSON a => Int -> Value -> Parser a
+        parseIndexedJSON idx value = parseJSON value <?> Index idx
+
+    parseJSONList v = typeMismatch "[a]" v
+
+
 -- | A key-value pair for encoding a JSON object.
 class KeyValue kv where
     (.=) :: ToJSON v => Text -> v -> kv
@@ -355,3 +402,100 @@ typeMismatch expected actual =
              Number _ -> "Number"
              Bool _   -> "Boolean"
              Null     -> "Null"
+
+-------------------------------------------------------------------------------
+-- Lifings of FromJSON and ToJSON to unary and binary type constructors
+-------------------------------------------------------------------------------
+
+-- | Lifting of the 'FromJSON' class to unary type constructors.
+class FromJSON1 f where
+    liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
+    liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]
+    liftParseJSONList f g v = listParser (liftParseJSON f g) v 
+
+-- | Lift the standard 'parseJSON' function through the type constructor.
+parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
+parseJSON1 = liftParseJSON parseJSON parseJSONList
+{-# INLINE parseJSON1 #-}
+
+-- | Lifting of the 'ToJSON' class to unary type constructors.
+class ToJSON1 f where
+    liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value
+    liftToJSONList :: (a -> Value) -> ([a] -> Value) -> [f a] -> Value
+    liftToJSONList f g = listValue (liftToJSON f g)
+
+    -- | Unfortunately there cannot be a default implementation of 'liftToEncoding'.
+    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
+    liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding
+    liftToEncodingList f g = listEncoding (liftToEncoding f g)
+
+-- | Lift the standard 'toJSON' function through the type constructor.
+toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value
+toJSON1 = liftToJSON toJSON toJSONList
+{-# INLINE toJSON1 #-}
+
+-- | Lift the standard 'toEncoding' function through the type constructor.
+toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding
+toEncoding1 = liftToEncoding toEncoding toEncodingList
+{-# INLINE toEncoding1 #-}
+
+
+-- | Lifting of the 'FromJSON' class to binary type constructors.
+class FromJSON2 f where
+    liftParseJSON2
+        :: (Value -> Parser a)
+        -> (Value -> Parser [a])
+        -> (Value -> Parser b)
+        -> (Value -> Parser [b])
+        -> Value -> Parser (f a b)
+    liftParseJSONList2 
+        :: (Value -> Parser a) 
+        -> (Value -> Parser [a]) 
+        -> (Value -> Parser b) 
+        -> (Value -> Parser [b]) 
+        -> Value -> Parser [f a b]
+    liftParseJSONList2 fa ga fb gb v = case v of
+        Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
+        _ -> typeMismatch "[a]" v
+
+-- | Lift the standard 'parseJSON' function through the type constructor.
+parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
+parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
+{-# INLINE parseJSON2 #-}
+
+-- | Lifting of the 'ToJSON' class to binary type constructors.
+class ToJSON2 f where
+    liftToJSON2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value
+    liftToJSONList2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value
+    liftToJSONList2 fa ga fb gb = listValue (liftToJSON2 fa ga fb gb)
+
+    liftToEncoding2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> f a b -> Encoding
+    liftToEncodingList2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> [f a b] -> Encoding
+    liftToEncodingList2 fa ga fb gb = listEncoding (liftToEncoding2 fa ga fb gb)
+
+-- | Lift the standard 'toJSON' function through the type constructor.
+toJSON2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Value
+toJSON2 = liftToJSON2 toJSON toJSONList toJSON toJSONList
+{-# INLINE toJSON2 #-}
+
+-- | Lift the standard 'toEncoding' function through the type constructor.
+toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding
+toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList
+{-# INLINE toEncoding2 #-}
+
+listEncoding :: (a -> Encoding) -> [a] -> Encoding
+listEncoding _  []     = emptyArray_
+listEncoding to (x:xs) = Encoding $
+                B.char7 '[' <> fromEncoding (to x) <> commas xs <> B.char7 ']'
+      where commas = foldr (\v vs -> B.char7 ',' <> fromEncoding (to v) <> vs) mempty
+{-# INLINE listEncoding #-}
+
+listValue :: (a -> Value) -> [a] -> Value
+listValue f = Array . V.fromList . map f
+{-# INLINE listValue #-}
+
+listParser :: (Value -> Parser a) -> Value -> Parser [a]
+listParser f (Array xs) = fmap V.toList (V.mapM f xs)
+listParser _ v          = typeMismatch "[a]" v
+
+