@@ -1,7 +1,7 @@
11{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,
22 FlexibleInstances, GeneralizedNewtypeDeriving,
33 OverloadedStrings, UndecidableInstances, ScopedTypeVariables,
4− ViewPatterns, InstanceSigs #-}
4+ ViewPatterns #-}
55{-# LANGUAGE DefaultSignatures #-}
66
77{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -30,10 +30,12 @@ module Data.Aeson.Types.Instances
3030 -- ** Keys for maps
3131 , ToJSONKey(..)
3232 , ToJSONKeyFunction(..)
33+ , contramapToJSONKeyFunction
3334 , FromJSONKey(..)
3435 , FromJSONKeyFunction(..)
3536 , fromJSONKeyCoerce
3637 , coerceFromJSONKeyFunction
38+ , mapFromJSONKeyFunction
3739 -- ** Liftings to unary and binary type constructors
3840 , FromJSON1(..)
3941 , parseJSON1
@@ -79,8 +81,8 @@ module Data.Aeson.Types.Instances
7981import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))
8082
8183import Control.Applicative (Const(..))
82−import Data.Aeson.Encode.Functions (brackets, builder, builder', encode, foldable, list)
83−import Data.Aeson.Functions (hashMapKey, mapHashKeyVal, mapKey, mapKeyVal)
84+import Data.Aeson.Encode.Functions (builder, builder', encode, foldable, list, encodeWithKey, encodeMap)
85+import Data.Aeson.Functions (mapHashKeyVal, mapKey, mapKeyVal)
8486import Data.Aeson.Types.Class
8587import Data.Aeson.Types.Internal
8688import Data.Attoparsec.Number (Number(..))
@@ -97,7 +99,7 @@ import Data.Proxy (Proxy(..))
9799import Data.Ratio (Ratio, (%), numerator, denominator)
98100import Data.Scientific (Scientific)
99101import Data.Tagged (Tagged(..))
100−import Data.Text (Text, pack, unpack)
102+import Data.Text (Text, unpack)
101103import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime,
102104 ZonedTime)
103105import Data.Time.Format (FormatTime, formatTime, parseTime)
@@ -109,7 +111,6 @@ import Text.ParserCombinators.ReadP (readP_to_S)
109111import Foreign.Storable (Storable)
110112import Numeric.Natural (Natural)
111113import Prelude hiding (foldr)
112−import qualified Prelude
113114import qualified Data.Aeson.Encode.Builder as E
114115import qualified Data.Aeson.Parser.Time as Time
115116import qualified Data.ByteString.Builder as B
@@ -151,40 +152,32 @@ import Data.Time.Format (defaultTimeLocale)
151152import System.Locale (defaultTimeLocale)
152153#endif
153154
154−parseIndexedJSON :: FromJSON a => Int -> Value -> Parser a
155−parseIndexedJSON = parseIndexedJSON' parseJSON
155+parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
156+parseIndexedJSON p idx value = p value <?> Index idx
157+{-# INLINE parseIndexedJSON #-}
156158
157−parseIndexedJSON' :: (Value -> Parser a) -> Int -> Value -> Parser a
158−parseIndexedJSON' p idx value = p value <?> Index idx
159−
160−parseIndexedJSONPair :: FromJSON b => (Value -> Parser a) -> Int -> Value -> Parser (a, b)
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
159+parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
160+parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
166161 where
167162 p = withArray "(k,v)" $ \ab ->
168163 let n = V.length ab
169164 in if n == 2
170− then (,) <$> parseJSONElemAtIndex' keyParser 0 ab
171− <*> parseJSONElemAtIndex' valParser 1 ab
165+ then (,) <$> parseJSONElemAtIndex keyParser 0 ab
166+ <*> parseJSONElemAtIndex valParser 1 ab
172167 else fail $ "cannot unpack array of length " ++
173168 show n ++ " into a pair"
174−{-# INLINE parseIndexedJSONPair' #-}
175169
170+ parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> Vector Value -> Parser a
171+ parseJSONElemAtIndex p' idx' ary = p' (V.unsafeIndex ary idx') <?> Index idx'
172+{-# INLINE parseIndexedJSONPair #-}
176173
177−toJSONPair :: 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
182−toJSONPair' keySerialiser valSerializer (a, b) = Array $ V.create $ do
174+toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
175+toJSONPair keySerialiser valSerializer (a, b) = Array $ V.create $ do
183176 mv <- VM.unsafeNew 2
184177 VM.unsafeWrite mv 0 (keySerialiser a)
185178 VM.unsafeWrite mv 1 (valSerializer b)
186179 return mv
187−{-# INLINE toJSONPair' #-}
180+{-# INLINE toJSONPair #-}
188181
189182
190183instance ToJSON1 Identity where
@@ -614,7 +607,7 @@ instance (ToJSON a) => ToJSON (NonEmpty a) where
614607
615608instance FromJSON1 NonEmpty where
616609 liftParseJSON p _ = withArray "NonEmpty a" $
617− (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON' p) [0..] . V.toList
610+ (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
618611 where
619612 ne [] = fail "Expected a NonEmpty but got an empty list"
620613 ne (x:xs) = pure (x :| xs)
@@ -662,7 +655,7 @@ instance (ToJSON a) => ToJSON (Seq.Seq a) where
662655instance FromJSON1 Seq.Seq where
663656 liftParseJSON p _ = withArray "Seq a" $
664657 fmap Seq.fromList .
665− Tr.sequence . zipWith (parseIndexedJSON' p) [0..] . V.toList
658+ Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
666659 {-# INLINE liftParseJSON #-}
667660
668661instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -700,7 +693,7 @@ encodeVector xs
700693
701694instance FromJSON1 Vector where
702695 liftParseJSON p _ = withArray "Vector a" $
703− V.mapM (uncurry $ parseIndexedJSON' p) . V.indexed
696+ V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
704697 {-# INLINE liftParseJSON #-}
705698
706699instance (FromJSON a) => FromJSON (Vector a) where
@@ -712,7 +705,7 @@ vectorToJSON = Array . V.map toJSON . V.convert
712705{-# INLINE vectorToJSON #-}
713706
714707vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
715−vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry parseIndexedJSON) . V.indexed
708+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexedJSON parseJSON) . V.indexed
716709{-# INLINE vectorParseJSON #-}
717710
718711instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
@@ -803,60 +796,19 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where
803796 parseJSON = fmap IntMap.fromList . parseJSON
804797 {-# INLINE parseJSON #-}
805798
806−encodeMap :: (ToJSON v)
807− => (k -> Encoding)
808− -> (m -> Maybe ((k,v), m))
809− -> ((k -> v -> B.Builder -> B.Builder) -> B.Builder -> m -> B.Builder)
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
819−encodeMap' encodeKey encodeVal minViewWithKey foldrWithKey xs =
820− case minViewWithKey xs of
821− Nothing -> E.emptyObject_
822− Just ((k,v),ys) -> Encoding $
823− B.char7 '{' <> encodeKV' encodeKey encodeVal k v <>
824− foldrWithKey go (B.char7 '}') ys
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' #-}
835−
836−encodeWithKey :: (ToJSON v)
837− => (k -> Encoding)
838− -> ((k -> v -> Series -> Series) -> Series -> m -> Series)
839− -> m -> Encoding
840−encodeWithKey encodeKey = encodeWithKey' encodeKey toEncoding
841−{-# INLINE encodeWithKey #-}
842−
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−
848799instance ToJSONKey k => ToJSON1 (M.Map k) where
849800 liftToJSON g _ = case toJSONKey of
850801 ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
851− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair' f g) . M.toList
802+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
852803 {-# INLINE liftToJSON #-}
853804
854− liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
805+ -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
855806 liftToEncoding g _ = case toJSONKey of
856− ToJSONKeyText (_,f) -> encodeMap' f g M.minViewWithKey M.foldrWithKey
807+ ToJSONKeyText (_,f) -> encodeMap f g M.minViewWithKey M.foldrWithKey
857808 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
809+ where
810+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
811+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b
860812 {-# INLINE liftToEncoding #-}
861813
862814instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
@@ -869,7 +821,7 @@ instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
869821 H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)
870822 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
871823 M.fromList <$> (Tr.sequence .
872− zipWith (parseIndexedJSONPair' f p) [0..] . V.toList $ arr)
824+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
873825 {-# INLINE liftParseJSON #-}
874826
875827instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where
@@ -886,15 +838,16 @@ instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where
886838instance ToJSONKey k => ToJSON1 (H.HashMap k) where
887839 liftToJSON g _ = case toJSONKey of
888840 ToJSONKeyText (f,_) -> Object . mapKeyVal f g
889− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair' f g) . H.toList
841+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . H.toList
890842 {-# INLINE liftToJSON #-}
891843
892− liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
844+ -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
893845 liftToEncoding g _ = case toJSONKey of
894− ToJSONKeyText (_,f) -> encodeWithKey' f g H.foldrWithKey
846+ ToJSONKeyText (_,f) -> encodeWithKey f g H.foldrWithKey
895847 ToJSONKeyValue (_,f) -> list (pairEncoding f) . H.toList
896− where pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
897− pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b
848+ where
849+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
850+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b
898851 {-# INLINE liftToEncoding #-}
899852
900853instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where
@@ -914,7 +867,7 @@ instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
914867 H.foldrWithKey (\k v m -> H.insert <$> f k <*> (p v <?> Key k) <*> m) (pure H.empty)
915868 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
916869 H.fromList <$> (Tr.sequence .
917− zipWith (parseIndexedJSONPair' f p) [0..] . V.toList $ arr)
870+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
918871 where
919872 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
920873 uc = unsafeCoerce
@@ -942,7 +895,7 @@ instance ToJSON Value where
942895 {-# INLINE toEncoding #-}
943896
944897instance FromJSON Value where
945− parseJSON a = pure a
898+ parseJSON = pure
946899 {-# INLINE parseJSON #-}
947900
948901instance ToJSON DotNetTime where
@@ -1005,12 +958,6 @@ stringEncoding :: (ToJSON a) => a -> Value
1005958stringEncoding = String . T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . encode
1006959{-# INLINE stringEncoding #-}
1007960
1008−parseJSONElemAtIndex :: FromJSON a => Int -> Vector Value -> Parser a
1009−parseJSONElemAtIndex = parseJSONElemAtIndex' parseJSON
1010−
1011−parseJSONElemAtIndex' :: (Value -> Parser a) -> Int -> Vector Value -> Parser a
1012−parseJSONElemAtIndex' p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
1013−
1014961instance FromJSON UTCTime where
1015962 parseJSON = withText "UTCTime" (Time.run Time.utcTime)
1016963
@@ -1240,13 +1187,7 @@ instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where
12401187instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
12411188 fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey
12421189
1243−contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
1244−contramapToJSONKeyFunction h x = case x of
1245− ToJSONKeyText (f,g) -> ToJSONKeyText (f . h, g . h)
1246− ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)
12471190
1248−mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
1249−mapFromJSONKeyFunction = fmap
12501191
12511192-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
12521193-- and fails using @'typeMismatch' expected@ otherwise.