38889ed · typeable/aeson

1−{-# LANGUAGE PatternGuards #-}

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

2

3-- Module: Data.Aeson.Generic

20 ) where

21

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

23−import Control.Arrow (first)

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

24import Control.Monad.State.Strict

25−import Data.Aeson.Functions (transformMap)

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

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

27import Data.Attoparsec.Number (Number)

26import Data.Attoparsec.Number (Number)

28import Data.Generics

27import Data.Generics

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

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

30import Data.IntSet (IntSet)

29import Data.IntSet (IntSet)

30+import Data.Maybe (fromJust)

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

32import Data.Time.Clock (UTCTime)

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

35import qualified Data.ByteString as B

36import qualified Data.ByteString.Lazy as L

37import qualified Data.Map as Map

38−import qualified Data.Traversable as T

39import qualified Data.Set as Set

38import 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

41import qualified Data.Vector as V

42import qualified Data.Vector as V

42

43

43type T a = a -> Value

44type T a = a -> Value

47 `ext1Q` list

48 `ext1Q` list

48 `ext1Q` vector

49 `ext1Q` vector

49 `ext1Q` set

50 `ext1Q` set

50− `ext1Q` mapText

51+ `ext2Q'` mapAny

51− `ext1Q` mapLazyText

52− `ext1Q` mapString

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

85+

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

86+ mapAny m

88− mapString m = Object . transformMap pack toJSON $ 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+

89

93

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

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

91toJSON_generic = generic

95toJSON_generic = generic

135parseJSON j = parseJSON_generic j

139parseJSON j = parseJSON_generic j

136 `ext1R` list

140 `ext1R` list

137 `ext1R` vector

141 `ext1R` vector

138− `ext1R` mapText

142+ `ext2R'` mapAny

139− `ext1R` mapLazyText

140− `ext1R` mapString

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

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

142 `extR` (value :: F Integer)

144 `extR` (value :: F Integer)

143 `extR` (value :: F Int)

145 `extR` (value :: F Int)

156 `extR` (value :: F Rational)

158 `extR` (value :: F Rational)

157 `extR` (value :: F Char)

159 `extR` (value :: F Char)

158 `extR` (value :: F Text)

160 `extR` (value :: F Text)

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

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

160 `extR` (value :: F String)

162 `extR` (value :: F String)

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

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

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

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

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

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

175 vector = case j of

177 vector = case j of

176 Array js -> V.mapM parseJSON js

178 Array js -> V.mapM parseJSON js

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

179+ _ -> myFail

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

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

179− mapText = case j of

184+ where res = case j of

180− Object js -> T.mapM parseJSON js

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

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

186+ _ -> myFail

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

187+ trans

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

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

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

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

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

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+

186

195

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

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

188parseJSON_generic j = generic

197parseJSON_generic j = generic

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

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

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

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

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

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

205− readConstr' t s =

214+ readConstr' t s =

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

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

207− show t)

216+ show t)

208− return $ readConstr t s

217+ return $ readConstr t s

209

218

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

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

211 (constrFields c0)

220 (constrFields c0)

247

256

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

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

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

258modFail 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 }