0a8aaf0 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Add higher kinded instances for Map and HashMap

0a8aaf0Andrew Martin10 years ago

Data/Aeson/Encode/Functions.hs+6

compare with master

unifiedsplit

@@ -4,6 +4,7 @@ module Data.Aeson.Encode.Functions

4 (

5 brackets

6 , builder

7+ , builder'

7 , char7

8 , char7

8 , encode

9 , encode

9 , foldable

10 , foldable

@@ -32,6 +33,11 @@ builder :: ToJSON a => a -> Builder

32builder = fromEncoding . toEncoding

33builder = fromEncoding . toEncoding

33{-# INLINE builder #-}

34{-# INLINE builder #-}

36+builder' :: (a -> Encoding) -> a -> Builder

37+builder' f = fromEncoding . f

38+{-# INLINE builder' #-}

39+

40+

35-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.

41-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.

36--

42--

37-- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.

43-- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.

Data/Aeson/Types/Instances.hs+84−15

@@ -1,7 +1,7 @@

1{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,

2 FlexibleInstances, GeneralizedNewtypeDeriving,

3 OverloadedStrings, UndecidableInstances, ScopedTypeVariables,

4− ViewPatterns #-}

4+ ViewPatterns, InstanceSigs #-}

5{-# LANGUAGE DefaultSignatures #-}

7{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -79,7 +79,7 @@ module Data.Aeson.Types.Instances

79import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))

81import Control.Applicative (Const(..))

82−import Data.Aeson.Encode.Functions (brackets, builder, encode, foldable, list)

82+import Data.Aeson.Encode.Functions (brackets, builder, builder', encode, foldable, list)

83import Data.Aeson.Functions (hashMapKey, mapHashKeyVal, mapKey, mapKeyVal)

84import Data.Aeson.Types.Class

85import Data.Aeson.Types.Internal

@@ -158,22 +158,34 @@ parseIndexedJSON' :: (Value -> Parser a) -> Int -> Value -> Parser a

158parseIndexedJSON' p idx value = p value <?> Index idx

159

160parseIndexedJSONPair :: FromJSON b => (Value -> Parser a) -> Int -> Value -> Parser (a, b)

161−parseIndexedJSONPair keyParser idx value = p value <?> Index idx

161+parseIndexedJSONPair keyParser = parseIndexedJSONPair' keyParser parseJSON

162+{-# INLINE parseIndexedJSONPair #-}

163+

164+parseIndexedJSONPair' :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)

165+parseIndexedJSONPair' keyParser valParser idx value = p value <?> Index idx

162 where

166 where

163 p = withArray "(k,v)" $ \ab ->

167 p = withArray "(k,v)" $ \ab ->

164 let n = V.length ab

168 let n = V.length ab

165 in if n == 2

169 in if n == 2

166 then (,) <$> parseJSONElemAtIndex' keyParser 0 ab

170 then (,) <$> parseJSONElemAtIndex' keyParser 0 ab

167− <*> parseJSONElemAtIndex 1 ab

171+ <*> parseJSONElemAtIndex' valParser 1 ab

168 else fail $ "cannot unpack array of length " ++

172 else fail $ "cannot unpack array of length " ++

169 show n ++ " into a pair"

173 show n ++ " into a pair"

174+{-# INLINE parseIndexedJSONPair' #-}

175+

170

176

171toJSONPair :: ToJSON b => (a -> Value) -> (a, b) -> Value

177toJSONPair :: ToJSON b => (a -> Value) -> (a, b) -> Value

178+toJSONPair f = toJSONPair' f toJSON

179+{-# INLINE toJSONPair #-}

180+

181+toJSONPair' :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

172−toJSONPair keySerialiser (a, b) = Array $ V.create $ do

182+toJSONPair' keySerialiser valSerializer (a, b) = Array $ V.create $ do

173 mv <- VM.unsafeNew 2

183 mv <- VM.unsafeNew 2

174 VM.unsafeWrite mv 0 (keySerialiser a)

184 VM.unsafeWrite mv 0 (keySerialiser a)

175− VM.unsafeWrite mv 1 (toJSON b)

185+ VM.unsafeWrite mv 1 (valSerializer b)

176 return mv

186 return mv

187+{-# INLINE toJSONPair' #-}

188+

177

189

178instance ToJSON1 Identity where

190instance ToJSON1 Identity where

179 liftToJSON to _ (Identity a) = to a

191 liftToJSON to _ (Identity a) = to a

@@ -796,26 +808,69 @@ encodeMap :: (ToJSON v)

796 -> (m -> Maybe ((k,v), m))

808 -> (m -> Maybe ((k,v), m))

797 -> ((k -> v -> B.Builder -> B.Builder) -> B.Builder -> m -> B.Builder)

809 -> ((k -> v -> B.Builder -> B.Builder) -> B.Builder -> m -> B.Builder)

798 -> m -> Encoding

810 -> m -> Encoding

811+encodeMap encodeKey = encodeMap' encodeKey toEncoding

812+{-# INLINE encodeMap #-}

813+

814+encodeMap' :: (k -> Encoding)

815+ -> (v -> Encoding)

816+ -> (m -> Maybe ((k,v), m))

817+ -> ((k -> v -> B.Builder -> B.Builder) -> B.Builder -> m -> B.Builder)

818+ -> m -> Encoding

799−encodeMap encodeKey minViewWithKey foldrWithKey xs =

819+encodeMap' encodeKey encodeVal minViewWithKey foldrWithKey xs =

800 case minViewWithKey xs of

820 case minViewWithKey xs of

801 Nothing -> E.emptyObject_

821 Nothing -> E.emptyObject_

802 Just ((k,v),ys) -> Encoding $

822 Just ((k,v),ys) -> Encoding $

803− B.char7 '{' <> encodeKV encodeKey k v <>

823+ B.char7 '{' <> encodeKV' encodeKey encodeVal k v <>

804 foldrWithKey go (B.char7 '}') ys

824 foldrWithKey go (B.char7 '}') ys

805− where go k v b = B.char7 ',' <> encodeKV encodeKey k v <> b

825+ where go k v b = B.char7 ',' <> encodeKV' encodeKey encodeVal k v <> b

806−{-# INLINE encodeMap #-}

826+{-# INLINE encodeMap' #-}

827+

828+encodeWithKey' :: (k -> Encoding)

829+ -> (v -> Encoding)

830+ -> ((k -> v -> Series -> Series) -> Series -> m -> Series)

831+ -> m -> Encoding

832+encodeWithKey' encodeKey encodeVal foldrWithKey = brackets '{' '}' . foldrWithKey go mempty

833+ where go k v c = Value (Encoding $ encodeKV' encodeKey encodeVal k v) <> c

834+{-# INLINE encodeWithKey' #-}

807

835

808encodeWithKey :: (ToJSON v)

836encodeWithKey :: (ToJSON v)

809 => (k -> Encoding)

837 => (k -> Encoding)

810 -> ((k -> v -> Series -> Series) -> Series -> m -> Series)

838 -> ((k -> v -> Series -> Series) -> Series -> m -> Series)

811 -> m -> Encoding

839 -> m -> Encoding

812−encodeWithKey encodeKey foldrWithKey = brackets '{' '}' . foldrWithKey go mempty

840+encodeWithKey encodeKey = encodeWithKey' encodeKey toEncoding

813− where go k v c = Value (Encoding $ encodeKV encodeKey k v) <> c

814{-# INLINE encodeWithKey #-}

841{-# INLINE encodeWithKey #-}

815

842

843+-- | TODO: rename to encodeKV

816−encodeKV :: (ToJSON v) => (k -> Encoding) -> k -> v -> B.Builder

844+encodeKV' :: (k -> Encoding) -> (v -> Encoding) -> k -> v -> B.Builder

817−encodeKV encodeKey k v = fromEncoding (encodeKey k) <> B.char7 ':' <> builder v

845+encodeKV' encodeKey encodeVal k v = fromEncoding (encodeKey k) <> B.char7 ':' <> builder' encodeVal v

818−{-# INLINE encodeKV #-}

846+{-# INLINE encodeKV' #-}

847+

848+instance ToJSONKey k => ToJSON1 (M.Map k) where

849+ liftToJSON g _ = case toJSONKey of

850+ ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g

851+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair' f g) . M.toList

852+ {-# INLINE liftToJSON #-}

853+

854+ liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding

855+ liftToEncoding g _ = case toJSONKey of

856+ ToJSONKeyText (_,f) -> encodeMap' f g M.minViewWithKey M.foldrWithKey

857+ ToJSONKeyValue (_,f) -> list (pairEncoding f) . M.toList

858+ where pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

859+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b

860+ {-# INLINE liftToEncoding #-}

861+

862+instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where

863+ liftParseJSON p _ = case fromJSONKey of

864+ FromJSONKeyCoerce _-> withObject "Map k v" $

865+ fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

866+ FromJSONKeyText f -> withObject "Map k v" $

867+ fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

868+ FromJSONKeyTextParser f -> withObject "Map k v" $

869+ H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)

870+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

871+ M.fromList <$> (Tr.sequence .

872+ zipWith (parseIndexedJSONPair' f p) [0..] . V.toList $ arr)

873+ {-# INLINE liftParseJSON #-}

819

874

820instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where

875instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where

821 toJSON = case toJSONKey of

876 toJSON = case toJSONKey of

@@ -843,6 +898,20 @@ instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where

843 zipWith (parseIndexedJSONPair f) [0..] . V.toList $ arr)

898 zipWith (parseIndexedJSONPair f) [0..] . V.toList $ arr)

844 {-# INLINE parseJSON #-}

899 {-# INLINE parseJSON #-}

845

900

901+instance ToJSONKey k => ToJSON1 (H.HashMap k) where

902+ liftToJSON g _ = case toJSONKey of

903+ ToJSONKeyText (f,_) -> Object . mapKeyVal f g

904+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair' f g) . H.toList

905+ {-# INLINE liftToJSON #-}

906+

907+ liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding

908+ liftToEncoding g _ = case toJSONKey of

909+ ToJSONKeyText (_,f) -> encodeWithKey' f g H.foldrWithKey

910+ ToJSONKeyValue (_,f) -> list (pairEncoding f) . H.toList

911+ where pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

912+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b

913+ {-# INLINE liftToEncoding #-}

914+

846instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where

915instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where

847 toJSON = case toJSONKey of

916 toJSON = case toJSONKey of

848 ToJSONKeyText (f,_) -> Object . mapKeyVal f toJSON

917 ToJSONKeyText (f,_) -> Object . mapKeyVal f toJSON