@@ -1,7 +1,7 @@
11{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,
22 FlexibleInstances, GeneralizedNewtypeDeriving,
33 OverloadedStrings, UndecidableInstances, ScopedTypeVariables,
4− ViewPatterns #-}
4+ ViewPatterns, InstanceSigs #-}
55{-# LANGUAGE DefaultSignatures #-}
66
77{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -79,7 +79,7 @@ module Data.Aeson.Types.Instances
7979import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))
8080
8181import 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)
8383import Data.Aeson.Functions (hashMapKey, mapHashKeyVal, mapKey, mapKeyVal)
8484import Data.Aeson.Types.Class
8585import Data.Aeson.Types.Internal
@@ -158,22 +158,34 @@ parseIndexedJSON' :: (Value -> Parser a) -> Int -> Value -> Parser a
158158parseIndexedJSON' p idx value = p value <?> Index idx
159159
160160parseIndexedJSONPair :: 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
162166 where
163167 p = withArray "(k,v)" $ \ab ->
164168 let n = V.length ab
165169 in if n == 2
166170 then (,) <$> parseJSONElemAtIndex' keyParser 0 ab
167− <*> parseJSONElemAtIndex 1 ab
171+ <*> parseJSONElemAtIndex' valParser 1 ab
168172 else fail $ "cannot unpack array of length " ++
169173 show n ++ " into a pair"
174+{-# INLINE parseIndexedJSONPair' #-}
175+
170176
171177toJSONPair :: ToJSON b => (a -> Value) -> (a, b) -> Value
172−toJSONPair keySerialiser (a, b) = Array $ V.create $ do
178+toJSONPair f = toJSONPair' f toJSON
179+{-# INLINE toJSONPair #-}
180+
181+toJSONPair' :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
182+toJSONPair' keySerialiser valSerializer (a, b) = Array $ V.create $ do
173183 mv <- VM.unsafeNew 2
174184 VM.unsafeWrite mv 0 (keySerialiser a)
175− VM.unsafeWrite mv 1 (toJSON b)
185+ VM.unsafeWrite mv 1 (valSerializer b)
176186 return mv
187+{-# INLINE toJSONPair' #-}
188+
177189
178190instance ToJSON1 Identity where
179191 liftToJSON to _ (Identity a) = to a
@@ -796,26 +808,69 @@ encodeMap :: (ToJSON v)
796808 -> (m -> Maybe ((k,v), m))
797809 -> ((k -> v -> B.Builder -> B.Builder) -> B.Builder -> m -> B.Builder)
798810 -> m -> Encoding
799−encodeMap encodeKey minViewWithKey foldrWithKey xs =
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
819+encodeMap' encodeKey encodeVal minViewWithKey foldrWithKey xs =
800820 case minViewWithKey xs of
801821 Nothing -> E.emptyObject_
802822 Just ((k,v),ys) -> Encoding $
803− B.char7 '{' <> encodeKV encodeKey k v <>
823+ B.char7 '{' <> encodeKV' encodeKey encodeVal k v <>
804824 foldrWithKey go (B.char7 '}') ys
805− where go k v b = B.char7 ',' <> encodeKV encodeKey k v <> b
806−{-# INLINE encodeMap #-}
825+ where go k v b = B.char7 ',' <> encodeKV' encodeKey encodeVal k v <> b
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' #-}
807835
808836encodeWithKey :: (ToJSON v)
809837 => (k -> Encoding)
810838 -> ((k -> v -> Series -> Series) -> Series -> m -> Series)
811839 -> m -> Encoding
812−encodeWithKey encodeKey foldrWithKey = brackets '{' '}' . foldrWithKey go mempty
813− where go k v c = Value (Encoding $ encodeKV encodeKey k v) <> c
840+encodeWithKey encodeKey = encodeWithKey' encodeKey toEncoding
814841{-# INLINE encodeWithKey #-}
815842
816−encodeKV :: (ToJSON v) => (k -> Encoding) -> k -> v -> B.Builder
817−encodeKV encodeKey k v = fromEncoding (encodeKey k) <> B.char7 ':' <> builder v
818−{-# INLINE encodeKV #-}
843+-- | TODO: rename to encodeKV
844+encodeKV' :: (k -> Encoding) -> (v -> Encoding) -> k -> v -> B.Builder
845+encodeKV' encodeKey encodeVal k v = fromEncoding (encodeKey k) <> B.char7 ':' <> builder' encodeVal v
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 #-}
819874
820875instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where
821876 toJSON = case toJSONKey of
@@ -843,6 +898,20 @@ instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where
843898 zipWith (parseIndexedJSONPair f) [0..] . V.toList $ arr)
844899 {-# INLINE parseJSON #-}
845900
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+
846915instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where
847916 toJSON = case toJSONKey of
848917 ToJSONKeyText (f,_) -> Object . mapKeyVal f toJSON