@@ -1,4 +1,4 @@
1−{-# LANGUAGE PatternGuards #-}
1+{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables #-}
22
33-- Module: Data.Aeson.Generic
44-- Copyright: (c) 2011 MailRank, Inc.
@@ -20,14 +20,14 @@ module Data.Aeson.Generic
2020 ) where
2121
2222import Control.Applicative ((<$>))
23−import Control.Arrow (first)
23+import Control.Arrow (first,(***))
2424import Control.Monad.State.Strict
25−import Data.Aeson.Functions (transformMap)
2625import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
2726import Data.Attoparsec.Number (Number)
2827import Data.Generics
2928import Data.Int (Int8, Int16, Int32, Int64)
3029import Data.IntSet (IntSet)
30+import Data.Maybe (fromJust)
3131import Data.Text (Text, pack, unpack)
3232import Data.Time.Clock (UTCTime)
3333import Data.Word (Word, Word8, Word16, Word32, Word64)
@@ -35,9 +35,10 @@ import qualified Data.Aeson.Types as T
3535import qualified Data.ByteString as B
3636import qualified Data.ByteString.Lazy as L
3737import qualified Data.Map as Map
38−import qualified Data.Traversable as T
3938import qualified Data.Set as Set
40−import qualified Data.Text.Lazy as L
39+import qualified Data.Text as DT
40+import qualified Data.Text.Lazy as LT
41+import qualified Data.Traversable as T
4142import qualified Data.Vector as V
4243
4344type T a = a -> Value
@@ -47,9 +48,7 @@ toJSON = toJSON_generic
4748 `ext1Q` list
4849 `ext1Q` vector
4950 `ext1Q` set
50− `ext1Q` mapText
51− `ext1Q` mapLazyText
52− `ext1Q` mapString
51+ `ext2Q'` mapAny
5352 -- Use the standard encoding for all base types.
5453 `extQ` (T.toJSON :: T Integer)
5554 `extQ` (T.toJSON :: T Int)
@@ -68,7 +67,7 @@ toJSON = toJSON_generic
6867 `extQ` (T.toJSON :: T Rational)
6968 `extQ` (T.toJSON :: T Char)
7069 `extQ` (T.toJSON :: T Text)
71− `extQ` (T.toJSON :: T L.Text)
70+ `extQ` (T.toJSON :: T LT.Text)
7271 `extQ` (T.toJSON :: T String)
7372 `extQ` (T.toJSON :: T B.ByteString)
7473 `extQ` (T.toJSON :: T L.ByteString)
@@ -83,9 +82,14 @@ toJSON = toJSON_generic
8382 list xs = Array . V.fromList . map toJSON $ xs
8483 vector v = Array . V.map toJSON $ v
8584 set s = Array . V.fromList . map toJSON . Set.toList $ s
86− mapText m = Object . Map.map toJSON $ m
87− mapLazyText m = Object . transformMap L.toStrict toJSON $ m
88− mapString m = Object . transformMap pack toJSON $ m
85+
86+ mapAny m
87+ | tyrep == typeOf "" = Object . Map.fromAscList . map ((pack . fromJust . cast) *** toJSON) . Map.toList $ m
88+ | tyrep == typeOf DT.empty = Object . Map.fromAscList . map ((fromJust . cast) *** toJSON) . Map.toList $ m
89+ | tyrep == typeOf LT.empty = Object . Map.fromAscList . map ((LT.toStrict . fromJust . cast) *** toJSON) . Map.toList $ m
90+ | otherwise = error $ "toJSON cannot convert map keyed by type: " ++ show tyrep
91+ where tyrep = typeOf $ head $ Map.keys m
92+
8993
9094toJSON_generic :: (Data a) => a -> Value
9195toJSON_generic = generic
@@ -135,9 +139,7 @@ parseJSON :: (Data a) => Value -> Parser a
135139parseJSON j = parseJSON_generic j
136140 `ext1R` list
137141 `ext1R` vector
138− `ext1R` mapText
139− `ext1R` mapLazyText
140− `ext1R` mapString
142+ `ext2R'` mapAny
141143 -- Use the standard encoding for all base types.
142144 `extR` (value :: F Integer)
143145 `extR` (value :: F Int)
@@ -156,7 +158,7 @@ parseJSON j = parseJSON_generic j
156158 `extR` (value :: F Rational)
157159 `extR` (value :: F Char)
158160 `extR` (value :: F Text)
159− `extR` (value :: F L.Text)
161+ `extR` (value :: F LT.Text)
160162 `extR` (value :: F String)
161163 `extR` (value :: F B.ByteString)
162164 `extR` (value :: F L.ByteString)
@@ -174,15 +176,22 @@ parseJSON j = parseJSON_generic j
174176 vector :: (Data a) => Parser (V.Vector a)
175177 vector = case j of
176178 Array js -> V.mapM parseJSON js
177− _ -> modFail "parseJSON" $ "bad data: " ++ show j
178− mapText :: (Data a) => Parser (Map.Map Text a)
179− mapText = case j of
180− Object js -> T.mapM parseJSON js
181− _ -> modFail "parseJSON" $ "bad data: " ++ show j
182− mapLazyText :: (Data a) => Parser (Map.Map L.Text a)
183− mapLazyText = Map.mapKeysMonotonic L.fromStrict <$> parseJSON j
184− mapString :: (Data a) => Parser (Map.Map String a)
185− mapString = Map.mapKeysMonotonic unpack <$> parseJSON j
179+ _ -> myFail
180+ mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
181+ mapAny
182+ | tyrep `elem` [typeOf LT.empty, typeOf DT.empty, typeOf ""] = res
183+ | otherwise = myFail
184+ where res = case j of
185+ Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js
186+ _ -> myFail
187+ trans
188+ | tyrep == typeOf DT.empty = fromJust . cast . id
189+ | tyrep == typeOf LT.empty = fromJust . cast . LT.fromStrict
190+ | tyrep == typeOf "" = fromJust . cast . DT.unpack
191+ | otherwise = error "parseJSON: mapAny -- should never happen"
192+ tyrep = typeOf (undefined :: f)
193+ myFail = modFail "parseJSON" $ "bad data: " ++ show j
194+
186195
187196parseJSON_generic :: (Data a) => Value -> Parser a
188197parseJSON_generic j = generic
@@ -202,10 +211,10 @@ parseJSON_generic j = generic
202211 getConstr t (String js) = do c <- readConstr' t (unpack js)
203212 return (c, Null) -- handle nullary ctor
204213 getConstr _ _ = modFail "parseJSON" "bad constructor encoding"
205− readConstr' t s =
206− maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
207− show t)
208− return $ readConstr t s
214+ readConstr' t s =
215+ maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
216+ show t)
217+ return $ readConstr t s
209218
210219 decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
211220 (constrFields c0)
@@ -247,3 +256,35 @@ parseJSON_generic j = generic
247256
248257modFail :: (Monad m) => String -> String -> m a
249258modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err
259+
260+
261+------------------------------------------------------------------------------
262+-- Type extension for binary type constructors
263+------------------------------------------------------------------------------
264+
265+-- | Flexible type extension
266+ext2' :: (Data a, Typeable2 t)
267+ => c a
268+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
269+ -> c a
270+ext2' def ext = maybe def id (dataCast2 ext)
271+
272+-- | Type extension of queries for type constructors
273+ext2Q' :: (Data d, Typeable2 t)
274+ => (d -> q)
275+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
276+ -> d -> q
277+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
278+
279+-- | Type extension of readers for type constructors
280+ext2R' :: (Monad m, Data d, Typeable2 t)
281+ => m d
282+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
283+ -> m d
284+ext2R' def ext = unR ((R def) `ext2'` (R ext))
285+
286+-- | The type constructor for queries
287+newtype Q q x = Q { unQ :: x -> q }
288+
289+-- | The type constructor for readers
290+newtype R m x = R { unR :: m x }