8d734c1 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge

8d734c1Bryan O'Sullivan16 years ago

Data/Aeson/Encode.hs+5−3

compare with master

unifiedsplit

@@ -18,19 +18,21 @@ module Data.Aeson.Encode

18import Blaze.ByteString.Builder

19import Blaze.ByteString.Builder.Char.Utf8

20import Data.Aeson.Types (ToJSON(..), Value(..))

21+import Data.Attoparsec.Number (Number(..))

21import Data.Monoid (mappend)

22import Data.Monoid (mappend)

22import Numeric (showHex)

23import Numeric (showHex)

23−import qualified Data.ByteString.Char8 as B

24import qualified Data.ByteString.Lazy.Char8 as L

25import qualified Data.Map as M

26import qualified Data.Text as T

27import qualified Data.Vector as V

28+import qualified Text.Show.ByteString as S

29-- | Encode a JSON value to a 'Builder'.

30-- | Encode a JSON value to a 'Builder'.

30fromValue :: Value -> Builder

31fromValue :: Value -> Builder

31fromValue Null = fromByteString "null"

32fromValue Null = fromByteString "null"

32fromValue (Bool b) = fromByteString $ if b then "true" else "false"

33fromValue (Bool b) = fromByteString $ if b then "true" else "false"

33−fromValue (Number n) = fromByteString (B.pack (show n))

34+fromValue (Number (I n)) = fromLazyByteString (S.show n)

35+fromValue (Number (D n)) = fromLazyByteString (S.show n)

34fromValue (String s) = string s

36fromValue (String s) = string s

35fromValue (Array v)

37fromValue (Array v)

36 | V.null v = fromByteString "[]"

38 | V.null v = fromByteString "[]"

@@ -52,7 +54,7 @@ string s = fromChar '"' `mappend` quote s `mappend` fromChar '"'

52 where

54 where

53 quote q = case T.uncons t of

55 quote q = case T.uncons t of

54 Just (c,t') -> fromText h `mappend` escape c `mappend` quote t'

56 Just (c,t') -> fromText h `mappend` escape c `mappend` quote t'

55− Nothing -> fromText h

57+ Nothing -> fromText h

56 where (h,t) = T.break isEscape q

58 where (h,t) = T.break isEscape q

57 isEscape c = c == '\"' || c == '\\' || c < '\x20'

59 isEscape c = c == '\"' || c == '\\' || c < '\x20'

58 escape '\"' = fromByteString "\\\""

60 escape '\"' = fromByteString "\\\""

Data/Aeson/Functions.hs+20−4

@@ -1,13 +1,29 @@

1module Data.Aeson.Functions

2 (

3+ hashMap

4+ , mapHash

3− transformMap

5+ , transformMap

4 ) where

6 ) where

6−import Control.Arrow ((***))

8+import Control.Arrow ((***), first)

9+import Data.Hashable (Hashable)

10+import qualified Data.HashMap.Strict as H

7import qualified Data.Map as M

11import qualified Data.Map as M

9-- | Transform one map into another. The ordering of keys must be

13-- | Transform one map into another. The ordering of keys must be

10−-- preserved.

14+-- preserved by the key transformation function.

11−transformMap :: (Ord k1, Ord k2) => (k1 -> k2) -> (v1 -> v2)

15+transformMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)

12 -> M.Map k1 v1 -> M.Map k2 v2

16 -> M.Map k1 v1 -> M.Map k2 v2

13transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList

17transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList

18+{-# INLINE transformMap #-}

19+

20+-- | Transform a 'H.HashMap' into a 'M.Map'.

21+hashMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)

22+ -> H.HashMap k1 v1 -> M.Map k2 v2

23+hashMap fk kv = M.fromList . map (fk *** kv) . H.toList

24+{-# INLINE hashMap #-}

25+

26+-- | Transform a 'M.Map' into a 'H.HashMap'.

27+mapHash :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.Map k1 v -> H.HashMap k2 v

28+mapHash fk = H.fromList . map (first fk) . M.toList

29+{-# INLINE mapHash #-}

Data/Aeson/Generic.hs+90−32

@@ -1,4 +1,4 @@

1−{-# LANGUAGE PatternGuards #-}

1+{-# LANGUAGE PatternGuards, RankNTypes, ScopedTypeVariables #-}

3-- Module: Data.Aeson.Generic

@@ -22,22 +22,25 @@ module Data.Aeson.Generic

22import Control.Applicative ((<$>))

23import Control.Arrow (first)

24import Control.Monad.State.Strict

25−import Data.Aeson.Functions (transformMap)

25+import Data.Aeson.Functions (hashMap, transformMap)

26import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)

27import Data.Attoparsec.Number (Number)

28import Data.Generics

29import Data.Int (Int8, Int16, Int32, Int64)

30import Data.IntSet (IntSet)

31+import Data.Maybe (fromJust)

31import Data.Text (Text, pack, unpack)

32import Data.Text (Text, pack, unpack)

32import Data.Time.Clock (UTCTime)

33import Data.Time.Clock (UTCTime)

33import Data.Word (Word, Word8, Word16, Word32, Word64)

34import Data.Word (Word, Word8, Word16, Word32, Word64)

34import qualified Data.Aeson.Types as T

35import qualified Data.Aeson.Types as T

35import qualified Data.ByteString as B

36import qualified Data.ByteString as B

36import qualified Data.ByteString.Lazy as L

37import qualified Data.ByteString.Lazy as L

38+import qualified Data.HashMap.Strict as H

37import qualified Data.Map as Map

39import qualified Data.Map as Map

38−import qualified Data.Traversable as T

39import qualified Data.Set as Set

40import qualified Data.Set as Set

40−import qualified Data.Text.Lazy as L

41+import qualified Data.Text as DT

42+import qualified Data.Text.Lazy as LT

43+import qualified Data.Traversable as T

41import qualified Data.Vector as V

44import qualified Data.Vector as V

43type T a = a -> Value

46type T a = a -> Value

@@ -47,9 +50,8 @@ toJSON = toJSON_generic

47 `ext1Q` list

50 `ext1Q` list

48 `ext1Q` vector

51 `ext1Q` vector

49 `ext1Q` set

52 `ext1Q` set

50− `ext1Q` mapText

53+ `ext2Q'` mapAny

51− `ext1Q` mapLazyText

54+ `ext2Q'` hashMapAny

52− `ext1Q` mapString

53 -- Use the standard encoding for all base types.

55 -- Use the standard encoding for all base types.

54 `extQ` (T.toJSON :: T Integer)

56 `extQ` (T.toJSON :: T Integer)

55 `extQ` (T.toJSON :: T Int)

57 `extQ` (T.toJSON :: T Int)

@@ -68,7 +70,7 @@ toJSON = toJSON_generic

68 `extQ` (T.toJSON :: T Rational)

70 `extQ` (T.toJSON :: T Rational)

69 `extQ` (T.toJSON :: T Char)

71 `extQ` (T.toJSON :: T Char)

70 `extQ` (T.toJSON :: T Text)

72 `extQ` (T.toJSON :: T Text)

71− `extQ` (T.toJSON :: T L.Text)

73+ `extQ` (T.toJSON :: T LT.Text)

72 `extQ` (T.toJSON :: T String)

74 `extQ` (T.toJSON :: T String)

73 `extQ` (T.toJSON :: T B.ByteString)

75 `extQ` (T.toJSON :: T B.ByteString)

74 `extQ` (T.toJSON :: T L.ByteString)

76 `extQ` (T.toJSON :: T L.ByteString)

@@ -83,9 +85,25 @@ toJSON = toJSON_generic

83 list xs = Array . V.fromList . map toJSON $ xs

85 list xs = Array . V.fromList . map toJSON $ xs

84 vector v = Array . V.map toJSON $ v

86 vector v = Array . V.map toJSON $ v

85 set s = Array . V.fromList . map toJSON . Set.toList $ s

87 set s = Array . V.fromList . map toJSON . Set.toList $ s

86− mapText m = Object . Map.map toJSON $ m

88+

87− mapLazyText m = Object . transformMap L.toStrict toJSON $ m

89+ mapAny m

88− mapString m = Object . transformMap pack toJSON $ m

90+ | tyrep == typeOf "" = remap pack

91+ | tyrep == typeOf DT.empty = remap id

92+ | tyrep == typeOf LT.empty = remap LT.toStrict

93+ | otherwise = modError "toJSON" $

94+ "cannot convert map keyed by type " ++ show tyrep

95+ where tyrep = typeOf . head . Map.keys $ m

96+ remap f = Object . transformMap (f . fromJust . cast) toJSON $ m

97+

98+ hashMapAny m

99+ | tyrep == typeOf "" = remap pack

100+ | tyrep == typeOf DT.empty = remap id

101+ | tyrep == typeOf LT.empty = remap LT.toStrict

102+ | otherwise = modError "toJSON" $

103+ "cannot convert map keyed by type " ++ show tyrep

104+ where tyrep = typeOf . head . H.keys $ m

105+ remap f = Object . hashMap (f . fromJust . cast) toJSON $ m

106+

107

90toJSON_generic :: (Data a) => a -> Value

108toJSON_generic :: (Data a) => a -> Value

91toJSON_generic = generic

109toJSON_generic = generic

@@ -104,8 +122,8 @@ toJSON_generic = generic

104 AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)

122 AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)

105 rep -> err (dataTypeOf a) rep

123 rep -> err (dataTypeOf a) rep

106 where

124 where

107− err dt r = error $ "Data.Aeson.Generic.toJSON: not AlgRep " ++

125+ err dt r = modError "toJSON" $ "not AlgRep " ++

108− show r ++ "(" ++ show dt ++ ")"

126+ show r ++ "(" ++ show dt ++ ")"

109 -- Encode nullary constructor as a string.

127 -- Encode nullary constructor as a string.

110 -- Encode non-nullary constructors as an object with the constructor

128 -- Encode non-nullary constructors as an object with the constructor

111 -- name as the single field and the arguments as the value.

129 -- name as the single field and the arguments as the value.

@@ -135,9 +153,8 @@ parseJSON :: (Data a) => Value -> Parser a

135parseJSON j = parseJSON_generic j

153parseJSON j = parseJSON_generic j

136 `ext1R` list

154 `ext1R` list

137 `ext1R` vector

155 `ext1R` vector

138− `ext1R` mapText

156+ `ext2R'` mapAny

139− `ext1R` mapLazyText

157+ -- Don't know how to support parsing HashMaps :-(

140− `ext1R` mapString

141 -- Use the standard encoding for all base types.

158 -- Use the standard encoding for all base types.

142 `extR` (value :: F Integer)

159 `extR` (value :: F Integer)

143 `extR` (value :: F Int)

160 `extR` (value :: F Int)

@@ -156,7 +173,7 @@ parseJSON j = parseJSON_generic j

156 `extR` (value :: F Rational)

173 `extR` (value :: F Rational)

157 `extR` (value :: F Char)

174 `extR` (value :: F Char)

158 `extR` (value :: F Text)

175 `extR` (value :: F Text)

159− `extR` (value :: F L.Text)

176+ `extR` (value :: F LT.Text)

160 `extR` (value :: F String)

177 `extR` (value :: F String)

161 `extR` (value :: F B.ByteString)

178 `extR` (value :: F B.ByteString)

162 `extR` (value :: F L.ByteString)

179 `extR` (value :: F L.ByteString)

@@ -174,15 +191,23 @@ parseJSON j = parseJSON_generic j

174 vector :: (Data a) => Parser (V.Vector a)

191 vector :: (Data a) => Parser (V.Vector a)

175 vector = case j of

192 vector = case j of

176 Array js -> V.mapM parseJSON js

193 Array js -> V.mapM parseJSON js

177− _ -> modFail "parseJSON" $ "bad data: " ++ show j

194+ _ -> myFail

178− mapText :: (Data a) => Parser (Map.Map Text a)

195+ mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)

196+ mapAny

197+ | tyrep `elem` [typeOf LT.empty, typeOf DT.empty, typeOf ""] = res

198+ | otherwise = myFail

179− mapText = case j of

199+ where res = case j of

180− Object js -> T.mapM parseJSON js

200+ Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js

181− _ -> modFail "parseJSON" $ "bad data: " ++ show j

201+ _ -> myFail

182− mapLazyText :: (Data a) => Parser (Map.Map L.Text a)

202+ trans

183− mapLazyText = Map.mapKeysMonotonic L.fromStrict <$> parseJSON j

203+ | tyrep == typeOf DT.empty = fromJust . cast . id

184− mapString :: (Data a) => Parser (Map.Map String a)

204+ | tyrep == typeOf LT.empty = fromJust . cast . LT.fromStrict

185− mapString = Map.mapKeysMonotonic unpack <$> parseJSON j

205+ | tyrep == typeOf "" = fromJust . cast . DT.unpack

206+ | otherwise = modError "parseJSON"

207+ "mapAny -- should never happen"

208+ tyrep = typeOf (undefined :: f)

209+ myFail = modFail "parseJSON" $ "bad data: " ++ show j

210+

186

211

187parseJSON_generic :: (Data a) => Value -> Parser a

212parseJSON_generic :: (Data a) => Value -> Parser a

188parseJSON_generic j = generic

213parseJSON_generic j = generic

@@ -190,7 +215,7 @@ parseJSON_generic j = generic

190 typ = dataTypeOf $ resType generic

215 typ = dataTypeOf $ resType generic

191 generic = case dataTypeRep typ of

216 generic = case dataTypeRep typ of

192 AlgRep [] -> case j of

217 AlgRep [] -> case j of

193− Null -> return (error "Empty type")

218+ Null -> return (modError "parseJSON" "empty type")

194 _ -> modFail "parseJSON" "no-constr bad data"

219 _ -> modFail "parseJSON" "no-constr bad data"

195 AlgRep [_] -> decodeArgs (indexConstr typ 1) j

220 AlgRep [_] -> decodeArgs (indexConstr typ 1) j

196 AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'

221 AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'

@@ -202,10 +227,10 @@ parseJSON_generic j = generic

202 getConstr t (String js) = do c <- readConstr' t (unpack js)

227 getConstr t (String js) = do c <- readConstr' t (unpack js)

203 return (c, Null) -- handle nullary ctor

228 return (c, Null) -- handle nullary ctor

204 getConstr _ _ = modFail "parseJSON" "bad constructor encoding"

229 getConstr _ _ = modFail "parseJSON" "bad constructor encoding"

205− readConstr' t s =

230+ readConstr' t s =

206− maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++

231+ maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++

207− show t)

232+ show t)

208− return $ readConstr t s

233+ return $ readConstr t s

209

234

210 decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0

235 decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0

211 (constrFields c0)

236 (constrFields c0)

@@ -243,7 +268,40 @@ parseJSON_generic j = generic

243 where f = do modify (+1); return undefined

268 where f = do modify (+1); return undefined

244

269

245 resType :: MonadPlus m => m a -> a

270 resType :: MonadPlus m => m a -> a

246− resType _ = error "resType"

271+ resType _ = modError "parseJSON" "resType"

247

272

248modFail :: (Monad m) => String -> String -> m a

273modFail :: (Monad m) => String -> String -> m a

249modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err

274modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err

275+

276+modError :: String -> String -> a

277+modError func err = error $ "Data.Aeson.Generic." ++ func ++ ": " ++ err

278+

279+

280+-- Type extension for binary type constructors.

281+

282+-- | Flexible type extension

283+ext2' :: (Data a, Typeable2 t)

284+ => c a

285+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))

286+ -> c a

287+ext2' def ext = maybe def id (dataCast2 ext)

288+

289+-- | Type extension of queries for type constructors

290+ext2Q' :: (Data d, Typeable2 t)

291+ => (d -> q)

292+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)

293+ -> d -> q

294+ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))

295+

296+-- | Type extension of readers for type constructors

297+ext2R' :: (Monad m, Data d, Typeable2 t)

298+ => m d

299+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))

300+ -> m d

301+ext2R' def ext = unR ((R def) `ext2'` (R ext))

302+

303+-- | The type constructor for queries

304+newtype Q q x = Q { unQ :: x -> q }

305+

306+-- | The type constructor for readers

307+newtype R m x = R { unR :: m x }

Data/Aeson/Types.hs+29−5

@@ -36,33 +36,34 @@ module Data.Aeson.Types

36 ) where

38import Control.Applicative

39−import Control.Monad (MonadPlus(..))

40−import Data.Monoid (Monoid(..))

41import Control.DeepSeq (NFData(..))

39import Control.DeepSeq (NFData(..))

40+import Control.Monad (MonadPlus(..))

41+import Data.Aeson.Functions (hashMap, mapHash, transformMap)

42+import Data.Attoparsec.Char8 (Number(..))

42import Data.Data (Data)

43import Data.Data (Data)

43import Data.Int (Int8, Int16, Int32, Int64)

44import Data.Int (Int8, Int16, Int32, Int64)

44−import qualified Data.IntSet as IntSet

45import Data.Map (Map)

46import Data.Monoid (Dual(..), First(..), Last(..))

47+import Data.Monoid (Monoid(..))

47import Data.Ratio (Ratio)

48import Data.Ratio (Ratio)

48import Data.String (IsString(..))

49import Data.String (IsString(..))

49import Data.Text (Text, pack, unpack)

50import Data.Text (Text, pack, unpack)

50import Data.Text.Encoding (decodeUtf8, encodeUtf8)

51import Data.Text.Encoding (decodeUtf8, encodeUtf8)

51import Data.Time.Clock (UTCTime)

52import Data.Time.Clock (UTCTime)

52import Data.Time.Format (FormatTime, formatTime, parseTime)

53import Data.Time.Format (FormatTime, formatTime, parseTime)

53−import Data.Attoparsec.Char8 (Number(..))

54import Data.Typeable (Typeable)

55import Data.Vector (Vector)

56import Data.Word (Word, Word8, Word16, Word32, Word64)

57import System.Locale (defaultTimeLocale)

58import qualified Data.ByteString as B

59import qualified Data.ByteString.Lazy as LB

60+import qualified Data.HashMap.Strict as H

61+import qualified Data.IntSet as IntSet

60import qualified Data.Map as M

62import qualified Data.Map as M

61import qualified Data.Set as Set

63import qualified Data.Set as Set

62import qualified Data.Text as T

64import qualified Data.Text as T

63import qualified Data.Text.Lazy as LT

65import qualified Data.Text.Lazy as LT

64import qualified Data.Vector as V

66import qualified Data.Vector as V

65−import Data.Aeson.Functions

67-- | The result of running a 'Parser'.

68-- | The result of running a 'Parser'.

68data Result a = Error String

69data Result a = Error String

@@ -531,6 +532,29 @@ instance (ToJSON v) => ToJSON (M.Map String v) where

531instance (FromJSON v) => FromJSON (M.Map String v) where

532instance (FromJSON v) => FromJSON (M.Map String v) where

532 parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON

533 parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON

533

534

535+instance (ToJSON v) => ToJSON (H.HashMap Text v) where

536+ toJSON = Object . hashMap id toJSON

537+ {-# INLINE toJSON #-}

538+

539+instance (FromJSON v) => FromJSON (H.HashMap Text v) where

540+ parseJSON (Object o) = H.fromList <$> go (M.toList o)

541+ where

542+ go ((k,v):kvs) = ((:) . (,) k) <$> parseJSON v <*> go kvs

543+ go _ = pure []

544+ parseJSON _ = empty

545+

546+instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where

547+ toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []

548+

549+instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where

550+ parseJSON = fmap (mapHash LT.fromStrict) . parseJSON

551+

552+instance (ToJSON v) => ToJSON (H.HashMap String v) where

553+ toJSON = Object . hashMap pack toJSON

554+

555+instance (FromJSON v) => FromJSON (H.HashMap String v) where

556+ parseJSON = fmap (mapHash unpack) . parseJSON

557+

534instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where

558instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where

535 toJSON = Object . transformMap decode toJSON

559 toJSON = Object . transformMap decode toJSON

536

560

aeson.cabal+3

@@ -90,13 +90,16 @@ library

90 base == 4.*,

91 blaze-builder >= 0.2.1.4,

92 bytestring,

93+ bytestring-show,

93 containers,

94 containers,

94 deepseq,

95 deepseq,

96+ hashable,

95 monads-fd,

97 monads-fd,

96 old-locale,

98 old-locale,

97 syb,

99 syb,

98 text >= 0.11.0.2,

100 text >= 0.11.0.2,

99 time,

101 time,

102+ unordered-containers,

100 vector >= 0.7

103 vector >= 0.7

101

104

102 if flag(developer)

105 if flag(developer)