8a24e09 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

More instance, reogranise a bit

8a24e09Oleg Grenrus10 years ago

Data/Aeson/Types.hs+4

compare with master

unifiedsplit

@@ -81,6 +81,10 @@ module Data.Aeson.Types

81 , (.!=)

82 , object

84+ , listEncoding

85+ , listValue

86+ , listParser

87+

84 -- * Generic and TH encoding configuration

88 -- * Generic and TH encoding configuration

85 , Options(..)

89 , Options(..)

86 , SumEncoding(..)

90 , SumEncoding(..)

Data/Aeson/Types/Class.hs+63−3

@@ -36,8 +36,10 @@ module Data.Aeson.Types.Class

36 , genericToEncoding

37 , genericParseJSON

38 -- * Classes and types for map keys

39+ , ToJSONKey(..)

39 , ToJSONKeyFunction(..)

40 , ToJSONKeyFunction(..)

40 , contramapToJSONKeyFunction

41 , contramapToJSONKeyFunction

42+ , FromJSONKey(..)

41 , FromJSONKeyFunction(..)

43 , FromJSONKeyFunction(..)

42 , fromJSONKeyCoerce

44 , fromJSONKeyCoerce

43 , coerceFromJSONKeyFunction

45 , coerceFromJSONKeyFunction

@@ -314,12 +316,35 @@ class FromJSON a where

314

316

315 parseJSONList v = typeMismatch "[a]" v

317 parseJSONList v = typeMismatch "[a]" v

316

318

319+-------------------------------------------------------------------------------

320+-- Object key-value pairs

321+-------------------------------------------------------------------------------

317

322

318-- | A key-value pair for encoding a JSON object.

323-- | A key-value pair for encoding a JSON object.

319class KeyValue kv where

324class KeyValue kv where

320 (.=) :: ToJSON v => Text -> v -> kv

325 (.=) :: ToJSON v => Text -> v -> kv

321 infixr 8 .=

326 infixr 8 .=

322

327

328+-------------------------------------------------------------------------------

329+-- Classes and types for map keys

330+-------------------------------------------------------------------------------

331+

332+class ToJSONKey a where

333+ toJSONKey :: ToJSONKeyFunction a

334+ default toJSONKey :: ToJSON a => ToJSONKeyFunction a

335+ toJSONKey = ToJSONKeyValue (toJSON, toEncoding)

336+ toJSONKeyList :: ToJSONKeyFunction [a]

337+ default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]

338+ toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)

339+

340+class FromJSONKey a where

341+ fromJSONKey :: FromJSONKeyFunction a

342+ default fromJSONKey :: FromJSON a => FromJSONKeyFunction a

343+ fromJSONKey = FromJSONKeyValue parseJSON

344+ fromJSONKeyList :: FromJSONKeyFunction [a]

345+ default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]

346+ fromJSONKeyList = FromJSONKeyValue parseJSON

347+

323data ToJSONKeyFunction a

348data ToJSONKeyFunction a

324 = ToJSONKeyText (a -> Text, a -> Encoding)

349 = ToJSONKeyText (a -> Text, a -> Encoding)

325 | ToJSONKeyValue (a -> Value, a -> Encoding)

350 | ToJSONKeyValue (a -> Value, a -> Encoding)

@@ -388,6 +413,10 @@ contramapToJSONKeyFunction h x = case x of

388mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

413mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

389mapFromJSONKeyFunction = fmap

414mapFromJSONKeyFunction = fmap

390

415

416+-------------------------------------------------------------------------------

417+-- Functions needed for documentation

418+-------------------------------------------------------------------------------

419+

391-- | Fail parsing due to a type mismatch, with a descriptive message.

420-- | Fail parsing due to a type mismatch, with a descriptive message.

392--

421--

393-- Example usage:

422-- Example usage:

@@ -491,11 +520,15 @@ toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding

491toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList

520toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList

492{-# INLINE toEncoding2 #-}

521{-# INLINE toEncoding2 #-}

493

522

523+-------------------------------------------------------------------------------

524+-- Encoding functions

525+-------------------------------------------------------------------------------

526+

494listEncoding :: (a -> Encoding) -> [a] -> Encoding

527listEncoding :: (a -> Encoding) -> [a] -> Encoding

495listEncoding _ [] = emptyArray_

528listEncoding _ [] = emptyArray_

496−listEncoding to (x:xs) = Encoding $

529+listEncoding to' (x:xs) = Encoding $

497− B.char7 '[' <> fromEncoding (to x) <> commas xs <> B.char7 ']'

530+ B.char7 '[' <> fromEncoding (to' x) <> commas xs <> B.char7 ']'

498− where commas = foldr (\v vs -> B.char7 ',' <> fromEncoding (to v) <> vs) mempty

531+ where commas = foldr (\v vs -> B.char7 ',' <> fromEncoding (to' v) <> vs) mempty

499{-# INLINE listEncoding #-}

532{-# INLINE listEncoding #-}

500

533

501listValue :: (a -> Value) -> [a] -> Value

534listValue :: (a -> Value) -> [a] -> Value

@@ -505,5 +538,32 @@ listValue f = Array . V.fromList . map f

505listParser :: (Value -> Parser a) -> Value -> Parser [a]

538listParser :: (Value -> Parser a) -> Value -> Parser [a]

506listParser f (Array xs) = fmap V.toList (V.mapM f xs)

539listParser f (Array xs) = fmap V.toList (V.mapM f xs)

507listParser _ v = typeMismatch "[a]" v

540listParser _ v = typeMismatch "[a]" v

541+{-# INLINE listParser #-}

542+

543+-------------------------------------------------------------------------------

544+-- [] instances

545+-------------------------------------------------------------------------------

546+

547+-- These are needed for key-class default definitions

548+

549+instance ToJSON1 [] where

550+ liftToJSON _ to' = to'

551+ {-# INLINE liftToJSON #-}

552+

553+ liftToEncoding _ to' = to'

554+ {-# INLINE liftToEncoding #-}

555+

556+instance (ToJSON a) => ToJSON [a] where

557+ toJSON = toJSON1

558+ {-# INLINE toJSON #-}

559+

560+ toEncoding = toEncoding1

561+ {-# INLINE toEncoding #-}

508

562

563+instance FromJSON1 [] where

564+ liftParseJSON _ p' = p'

565+ {-# INLINE liftParseJSON #-}

509

566

567+instance (FromJSON a) => FromJSON [a] where

568+ parseJSON = parseJSON1

569+ {-# INLINE parseJSON #-}

Data/Aeson/Types/Instances.hs+294−195

@@ -76,6 +76,10 @@ module Data.Aeson.Types.Instances

76 , tuple

77 , (>*<)

78 , typeMismatch

79+

80+ , listEncoding

81+ , listValue

82+ , listParser

79 ) where

83 ) where

81import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))

85import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))

@@ -152,6 +156,10 @@ import Data.Time.Format (defaultTimeLocale)

152import System.Locale (defaultTimeLocale)

156import System.Locale (defaultTimeLocale)

153#endif

157#endif

154

158

159+-------------------------------------------------------------------------------

160+-- Helpers

161+-------------------------------------------------------------------------------

162+

155parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

163parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

156parseIndexedJSON p idx value = p value <?> Index idx

164parseIndexedJSON p idx value = p value <?> Index idx

157{-# INLINE parseIndexedJSON #-}

165{-# INLINE parseIndexedJSON #-}

@@ -179,6 +187,40 @@ toJSONPair keySerialiser valSerializer (a, b) = Array $ V.create $ do

179 return mv

187 return mv

180{-# INLINE toJSONPair #-}

188{-# INLINE toJSONPair #-}

181

189

190+realFloatToJSON :: RealFloat a => a -> Value

191+realFloatToJSON d

192+ | isNaN d || isInfinite d = Null

193+ | otherwise = Number $ Scientific.fromFloatDigits d

194+{-# INLINE realFloatToJSON #-}

195+

196+realFloatToEncoding :: RealFloat a => a -> Encoding

197+realFloatToEncoding d

198+ | isNaN d || isInfinite d = Encoding E.null_

199+ | otherwise = toEncoding (Scientific.fromFloatDigits d)

200+{-# INLINE realFloatToEncoding #-}

201+

202+scientificToNumber :: Scientific -> Number

203+scientificToNumber s

204+ | e < 0 = D $ Scientific.toRealFloat s

205+ | otherwise = I $ c * 10 ^ e

206+ where

207+ e = Scientific.base10Exponent s

208+ c = Scientific.coefficient s

209+{-# INLINE scientificToNumber #-}

210+

211+parseRealFloat :: RealFloat a => String -> Value -> Parser a

212+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s

213+parseRealFloat _ Null = pure (0/0)

214+parseRealFloat expected v = typeMismatch expected v

215+{-# INLINE parseRealFloat #-}

216+

217+parseIntegral :: Integral a => String -> Value -> Parser a

218+parseIntegral expected = withScientific expected $ pure . truncate

219+{-# INLINE parseIntegral #-}

220+

221+-------------------------------------------------------------------------------

222+-- base

223+-------------------------------------------------------------------------------

182

224

183instance ToJSON1 Identity where

225instance ToJSON1 Identity where

184 liftToJSON to _ (Identity a) = to a

226 liftToJSON to _ (Identity a) = to a

@@ -203,6 +245,40 @@ instance (FromJSON a) => FromJSON (Identity a) where

203 {-# INLINE parseJSON #-}

245 {-# INLINE parseJSON #-}

204

246

205

247

248+instance ToJSON2 Const where

249+ liftToJSON2 to _ _ _ (Const x) = to x

250+ {-# INLINE liftToJSON2 #-}

251+

252+ liftToEncoding2 to _ _ _ (Const x) = to x

253+ {-# INLINE liftToEncoding2 #-}

254+

255+instance FromJSON2 Const where

256+ liftParseJSON2 p _ _ _ = fmap Const . p

257+ {-# INLINE liftParseJSON2 #-}

258+

259+instance ToJSON a => ToJSON1 (Const a) where

260+ liftToJSON _ _ (Const x) = toJSON x

261+ {-# INLINE liftToJSON #-}

262+

263+ liftToEncoding _ _ (Const x) = toEncoding x

264+ {-# INLINE liftToEncoding #-}

265+

266+instance FromJSON a => FromJSON1 (Const a) where

267+ liftParseJSON _ _ = fmap Const . parseJSON

268+ {-# INLINE liftParseJSON #-}

269+

270+instance ToJSON a => ToJSON (Const a b) where

271+ toJSON (Const x) = toJSON x

272+ {-# INLINE toJSON #-}

273+

274+ toEncoding (Const x) = toEncoding x

275+ {-# INLINE toEncoding #-}

276+

277+instance FromJSON a => FromJSON (Const a b) where

278+ {-# INLINE parseJSON #-}

279+ parseJSON = fmap Const . parseJSON

280+

281+

206instance ToJSON1 Maybe where

282instance ToJSON1 Maybe where

207 liftToJSON to _ (Just a) = to a

283 liftToJSON to _ (Just a) = to a

208 liftToJSON _ _ Nothing = Null

284 liftToJSON _ _ Nothing = Null

@@ -282,6 +358,7 @@ left, right :: Text

282left = "Left"

358left = "Left"

283right = "Right"

359right = "Right"

284

360

361+

285instance ToJSON Bool where

362instance ToJSON Bool where

286 toJSON = Bool

363 toJSON = Bool

287 {-# INLINE toJSON #-}

364 {-# INLINE toJSON #-}

@@ -348,17 +425,6 @@ instance FromJSON Char where

348 parseJSONList = withText "String" $ pure . T.unpack

425 parseJSONList = withText "String" $ pure . T.unpack

349 {-# INLINE parseJSONList #-}

426 {-# INLINE parseJSONList #-}

350

427

351−instance ToJSON Scientific where

352− toJSON = Number

353− {-# INLINE toJSON #-}

354−

355− toEncoding = Encoding . E.number

356− {-# INLINE toEncoding #-}

357−

358−instance FromJSON Scientific where

359− parseJSON = withScientific "Scientific" pure

360− {-# INLINE parseJSON #-}

361−

362instance ToJSON Double where

428instance ToJSON Double where

363 toJSON = realFloatToJSON

429 toJSON = realFloatToJSON

364 {-# INLINE toJSON #-}

430 {-# INLINE toJSON #-}

@@ -591,6 +657,25 @@ instance FromJSON LT.Text where

591 parseJSON = withText "Lazy Text" $ pure . LT.fromStrict

657 parseJSON = withText "Lazy Text" $ pure . LT.fromStrict

592 {-# INLINE parseJSON #-}

658 {-# INLINE parseJSON #-}

593

659

660+instance ToJSON Version where

661+ toJSON = toJSON . showVersion

662+ {-# INLINE toJSON #-}

663+

664+ toEncoding = toEncoding . showVersion

665+ {-# INLINE toEncoding #-}

666+

667+instance FromJSON Version where

668+ {-# INLINE parseJSON #-}

669+ parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack

670+ where

671+ go [(v,[])] = return v

672+ go (_ : xs) = go xs

673+ go _ = fail $ "could not parse Version"

674+

675+-------------------------------------------------------------------------------

676+-- semigroups NonEmpty

677+-------------------------------------------------------------------------------

678+

594instance ToJSON1 NonEmpty where

679instance ToJSON1 NonEmpty where

595 liftToJSON to _ = listValue to . toList

680 liftToJSON to _ = listValue to . toList

596 {-# INLINE liftToJSON #-}

681 {-# INLINE liftToJSON #-}

@@ -615,29 +700,27 @@ instance FromJSON1 NonEmpty where

615

700

616instance (FromJSON a) => FromJSON (NonEmpty a) where

701instance (FromJSON a) => FromJSON (NonEmpty a) where

617 parseJSON = parseJSON1

702 parseJSON = parseJSON1

703+ {-# INLINE parseJSON #-}

618

704

619−instance ToJSON1 [] where

705+-------------------------------------------------------------------------------

620− liftToJSON _ to' = to'

706+-- scientific

621− {-# INLINE liftToJSON #-}

707+-------------------------------------------------------------------------------

622−

623− liftToEncoding _ to' = to'

624− {-# INLINE liftToEncoding #-}

625

708

626−instance (ToJSON a) => ToJSON [a] where

709+instance ToJSON Scientific where

627− toJSON = toJSON1

710+ toJSON = Number

628 {-# INLINE toJSON #-}

711 {-# INLINE toJSON #-}

629

712

630− toEncoding = toEncoding1

713+ toEncoding = Encoding . E.number

631 {-# INLINE toEncoding #-}

714 {-# INLINE toEncoding #-}

632

715

633−instance FromJSON1 [] where

634− liftParseJSON _ p' = p'

635− {-# INLINE liftParseJSON #-}

636−

637−instance (FromJSON a) => FromJSON [a] where

716+instance FromJSON Scientific where

638− parseJSON = parseJSON1

717+ parseJSON = withScientific "Scientific" pure

639 {-# INLINE parseJSON #-}

718 {-# INLINE parseJSON #-}

640

719

720+-------------------------------------------------------------------------------

721+-- containers

722+-------------------------------------------------------------------------------

723+

641instance ToJSON1 Seq.Seq where

724instance ToJSON1 Seq.Seq where

642 liftToJSON to _ = listValue to . toList

725 liftToJSON to _ = listValue to . toList

643 {-# INLINE liftToJSON #-}

726 {-# INLINE liftToJSON #-}

@@ -662,6 +745,152 @@ instance (FromJSON a) => FromJSON (Seq.Seq a) where

662 parseJSON = parseJSON1

745 parseJSON = parseJSON1

663 {-# INLINE parseJSON #-}

746 {-# INLINE parseJSON #-}

664

747

748+

749+instance ToJSON1 Set.Set where

750+ liftToJSON to _ = listValue to . Set.toList

751+ {-# INLINE liftToJSON #-}

752+

753+ liftToEncoding to _ = listEncoding to . Set.toList

754+ {-# INLINE liftToEncoding #-}

755+

756+instance (ToJSON a) => ToJSON (Set.Set a) where

757+ toJSON = toJSON1

758+ {-# INLINE toJSON #-}

759+

760+ toEncoding = toEncoding1

761+ {-# INLINE toEncoding #-}

762+

763+instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where

764+ parseJSON = fmap Set.fromList . parseJSON

765+ {-# INLINE parseJSON #-}

766+

767+

768+instance FromJSON IntSet.IntSet where

769+ parseJSON = fmap IntSet.fromList . parseJSON

770+ {-# INLINE parseJSON #-}

771+

772+instance ToJSON IntSet.IntSet where

773+ toJSON = toJSON . IntSet.toList

774+ {-# INLINE toJSON #-}

775+

776+ toEncoding = toEncoding . IntSet.toList

777+ {-# INLINE toEncoding #-}

778+

779+

780+instance ToJSON1 IntMap.IntMap where

781+ liftToJSON to tol = liftToJSON to' tol' . IntMap.toList

782+ where

783+ to' = liftToJSON2 toJSON toJSONList to tol

784+ tol' = liftToJSONList2 toJSON toJSONList to tol

785+ {-# INLINE liftToJSON #-}

786+

787+ liftToEncoding to tol = liftToEncoding to' tol' . IntMap.toList

788+ where

789+ to' = liftToEncoding2 toEncoding toEncodingList to tol

790+ tol' = liftToEncodingList2 toEncoding toEncodingList to tol

791+ {-# INLINE liftToEncoding #-}

792+

793+instance ToJSON a => ToJSON (IntMap.IntMap a) where

794+ toJSON = toJSON1

795+ {-# INLINE toJSON #-}

796+

797+ toEncoding = toEncoding1

798+ {-# INLINE toEncoding #-}

799+

800+instance FromJSON1 IntMap.IntMap where

801+ liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl'

802+ where

803+ p' = liftParseJSON2 parseJSON parseJSONList p pl

804+ pl' = liftParseJSONList2 parseJSON parseJSONList p pl

805+ {-# INLINE liftParseJSON #-}

806+

807+instance FromJSON a => FromJSON (IntMap.IntMap a) where

808+ parseJSON = fmap IntMap.fromList . parseJSON

809+ {-# INLINE parseJSON #-}

810+

811+

812+instance ToJSONKey k => ToJSON1 (M.Map k) where

813+ liftToJSON g _ = case toJSONKey of

814+ ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g

815+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList

816+ {-# INLINE liftToJSON #-}

817+

818+ -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding

819+ liftToEncoding g _ = case toJSONKey of

820+ ToJSONKeyText (_,f) -> encodeMap f g M.minViewWithKey M.foldrWithKey

821+ ToJSONKeyValue (_,f) -> list (pairEncoding f) . M.toList

822+ where

823+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

824+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b

825+ {-# INLINE liftToEncoding #-}

826+

827+instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where

828+ liftParseJSON p _ = case fromJSONKey of

829+ FromJSONKeyCoerce _-> withObject "Map k v" $

830+ fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

831+ FromJSONKeyText f -> withObject "Map k v" $

832+ fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

833+ FromJSONKeyTextParser f -> withObject "Map k v" $

834+ H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)

835+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

836+ M.fromList <$> (Tr.sequence .

837+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

838+ {-# INLINE liftParseJSON #-}

839+

840+instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where

841+ toJSON = toJSON1

842+ {-# INLINE toJSON #-}

843+

844+ toEncoding = toEncoding1

845+ {-# INLINE toEncoding #-}

846+

847+instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where

848+ parseJSON = parseJSON1

849+ {-# INLINE parseJSON #-}

850+

851+

852+instance ToJSON1 Tree.Tree where

853+ liftToJSON to tol = go

854+ where

855+ go (Tree.Node root branches) =

856+ liftToJSON2 to tol to' tol' (root, branches)

857+

858+ to' = liftToJSON go (listValue go)

859+ tol' = liftToJSONList go (listValue go)

860+ {-# INLINE liftToJSON #-}

861+

862+ liftToEncoding to tol = go

863+ where

864+ go (Tree.Node root branches) =

865+ liftToEncoding2 to tol to' tol' (root, branches)

866+

867+ to' = liftToEncoding go (listEncoding go)

868+ tol' = liftToEncodingList go (listEncoding go)

869+ {-# INLINE liftToEncoding #-}

870+

871+instance (ToJSON v) => ToJSON (Tree.Tree v) where

872+ toJSON = toJSON1

873+ {-# INLINE toJSON #-}

874+

875+ toEncoding = toEncoding1

876+ {-# INLINE toEncoding #-}

877+

878+instance FromJSON1 Tree.Tree where

879+ liftParseJSON p pl = go

880+ where

881+ go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v

882+

883+ p' = liftParseJSON go (listParser go)

884+ pl'= liftParseJSONList go (listParser go)

885+

886+instance (FromJSON v) => FromJSON (Tree.Tree v) where

887+ parseJSON = parseJSON1

888+ {-# INLINE parseJSON #-}

889+

890+-------------------------------------------------------------------------------

891+-- vector

892+-------------------------------------------------------------------------------

893+

665instance ToJSON1 Vector where

894instance ToJSON1 Vector where

666 liftToJSON to _ = Array . V.map to

895 liftToJSON to _ = Array . V.map to

667 {-# INLINE liftToJSON #-}

896 {-# INLINE liftToJSON #-}

@@ -740,101 +969,29 @@ instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where

740 parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

969 parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

741 {-# INLINE parseJSON #-}

970 {-# INLINE parseJSON #-}

742

971

743−instance (ToJSON a) => ToJSON (Set.Set a) where

972+-------------------------------------------------------------------------------

744− toJSON = toJSON . Set.toList

973+-- unordered-containers

745− {-# INLINE toJSON #-}

974+-------------------------------------------------------------------------------

746−

747− toEncoding = encodeSet Set.minView Set.foldr

748− {-# INLINE toEncoding #-}

749−

750−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where

751− parseJSON = fmap Set.fromList . parseJSON

752− {-# INLINE parseJSON #-}

753−

754−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where

755− toJSON = toJSON . HashSet.toList

756− {-# INLINE toJSON #-}

757

975

758− toEncoding = foldable toEncoding

976+instance ToJSON1 HashSet.HashSet where

759− {-# INLINE toEncoding #-}

977+ liftToJSON to _ = listValue to . HashSet.toList

760−

761−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where

762− parseJSON = fmap HashSet.fromList . parseJSON

763− {-# INLINE parseJSON #-}

764−

765−instance ToJSON IntSet.IntSet where

766− toJSON = toJSON . IntSet.toList

767− {-# INLINE toJSON #-}

768−

769− toEncoding = encodeSet IntSet.minView IntSet.foldr

770− {-# INLINE toEncoding #-}

771−

772−encodeSet :: (ToJSON a) =>

773− (s -> Maybe (a, s))

774− -> ((a -> B.Builder -> B.Builder) -> B.Builder -> s -> B.Builder)

775− -> s -> Encoding

776−encodeSet minView foldr xs =

777− case minView xs of

778− Nothing -> E.emptyArray_

779− Just (m,ys) -> Encoding $

780− B.char7 '[' <> builder m <> foldr go (B.char7 ']') ys

781− where go v b = B.char7 ',' <> builder v <> b

782−{-# INLINE encodeSet #-}

783−

784−instance FromJSON IntSet.IntSet where

785− parseJSON = fmap IntSet.fromList . parseJSON

786− {-# INLINE parseJSON #-}

787−

788−instance ToJSON a => ToJSON (IntMap.IntMap a) where

789− toJSON = toJSON . IntMap.toList

790− {-# INLINE toJSON #-}

791−

792− toEncoding = toEncoding . IntMap.toList

793− {-# INLINE toEncoding #-}

794−

795−instance FromJSON a => FromJSON (IntMap.IntMap a) where

796− parseJSON = fmap IntMap.fromList . parseJSON

797− {-# INLINE parseJSON #-}

798−

799−instance ToJSONKey k => ToJSON1 (M.Map k) where

800− liftToJSON g _ = case toJSONKey of

801− ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g

802− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList

803 {-# INLINE liftToJSON #-}

978 {-# INLINE liftToJSON #-}

804

979

805− -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding

980+ liftToEncoding to _ = listEncoding to . HashSet.toList

806− liftToEncoding g _ = case toJSONKey of

807− ToJSONKeyText (_,f) -> encodeMap f g M.minViewWithKey M.foldrWithKey

808− ToJSONKeyValue (_,f) -> list (pairEncoding f) . M.toList

809− where

810− -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

811− pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b

812 {-# INLINE liftToEncoding #-}

981 {-# INLINE liftToEncoding #-}

813

982

814−instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where

815− liftParseJSON p _ = case fromJSONKey of

816− FromJSONKeyCoerce _-> withObject "Map k v" $

817− fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

818− FromJSONKeyText f -> withObject "Map k v" $

819− fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)

820− FromJSONKeyTextParser f -> withObject "Map k v" $

821− H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)

822− FromJSONKeyValue f -> withArray "Map k v" $ \arr ->

823− M.fromList <$> (Tr.sequence .

824− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)

825− {-# INLINE liftParseJSON #-}

826−

827−instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where

983+instance (ToJSON a) => ToJSON (HashSet.HashSet a) where

828 toJSON = toJSON1

984 toJSON = toJSON1

829 {-# INLINE toJSON #-}

985 {-# INLINE toJSON #-}

830

986

831 toEncoding = toEncoding1

987 toEncoding = toEncoding1

832 {-# INLINE toEncoding #-}

988 {-# INLINE toEncoding #-}

833

989

834−instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where

990+instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where

835− parseJSON = parseJSON1

991+ parseJSON = fmap HashSet.fromList . parseJSON

836 {-# INLINE parseJSON #-}

992 {-# INLINE parseJSON #-}

837

993

994+

838instance ToJSONKey k => ToJSON1 (H.HashMap k) where

995instance ToJSONKey k => ToJSON1 (H.HashMap k) where

839 liftToJSON g _ = case toJSONKey of

996 liftToJSON g _ = case toJSONKey of

840 ToJSONKeyText (f,_) -> Object . mapKeyVal f g

997 ToJSONKeyText (f,_) -> Object . mapKeyVal f g

@@ -876,16 +1033,9 @@ instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k

876 parseJSON = parseJSON1

1033 parseJSON = parseJSON1

877 {-# INLINE parseJSON #-}

1034 {-# INLINE parseJSON #-}

878

1035

879−instance (ToJSON v) => ToJSON (Tree.Tree v) where

1036+-------------------------------------------------------------------------------

880− toJSON (Tree.Node root branches) = toJSON (root,branches)

1037+-- aeson

881− {-# INLINE toJSON #-}

1038+-------------------------------------------------------------------------------

882−

883− toEncoding (Tree.Node root branches) = toEncoding (root,branches)

884− {-# INLINE toEncoding #-}

885−

886−instance (FromJSON v) => FromJSON (Tree.Tree v) where

887− parseJSON j = uncurry Tree.Node <$> parseJSON j

888− {-# INLINE parseJSON #-}

889

1039

890instance ToJSON Value where

1040instance ToJSON Value where

891 toJSON a = a

1041 toJSON a = a

@@ -916,6 +1066,10 @@ instance FromJSON DotNetTime where

916 _ -> fail "could not parse .NET time"

1066 _ -> fail "could not parse .NET time"

917 {-# INLINE parseJSON #-}

1067 {-# INLINE parseJSON #-}

918

1068

1069+-------------------------------------------------------------------------------

1070+-- time

1071+-------------------------------------------------------------------------------

1072+

919instance ToJSON Day where

1073instance ToJSON Day where

920 toJSON = stringEncoding

1074 toJSON = stringEncoding

921 toEncoding z = Encoding (E.quote $ E.day z)

1075 toEncoding z = Encoding (E.quote $ E.day z)

@@ -976,6 +1130,10 @@ instance FromJSON NominalDiffTime where

976 parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac

1130 parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac

977 {-# INLINE parseJSON #-}

1131 {-# INLINE parseJSON #-}

978

1132

1133+-------------------------------------------------------------------------------

1134+-- base Monoid/Semigroup

1135+-------------------------------------------------------------------------------

1136+

979instance ToJSON1 Dual where

1137instance ToJSON1 Dual where

980 liftToJSON to _ = to . getDual

1138 liftToJSON to _ = to . getDual

981 {-# INLINE liftToJSON #-}

1139 {-# INLINE liftToJSON #-}

@@ -1044,21 +1202,9 @@ instance FromJSON a => FromJSON (Last a) where

1044 parseJSON = parseJSON1

1202 parseJSON = parseJSON1

1045 {-# INLINE parseJSON #-}

1203 {-# INLINE parseJSON #-}

1046

1204

1047−

1205+-------------------------------------------------------------------------------

1048−instance ToJSON Version where

1206+-- tagged

1049− toJSON = toJSON . showVersion

1207+-------------------------------------------------------------------------------

1050− {-# INLINE toJSON #-}

1051−

1052− toEncoding = toEncoding . showVersion

1053− {-# INLINE toEncoding #-}

1054−

1055−instance FromJSON Version where

1056− {-# INLINE parseJSON #-}

1057− parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack

1058− where

1059− go [(v,[])] = return v

1060− go (_ : xs) = go xs

1061− go _ = fail $ "could not parse Version"

1062

1208

1063instance ToJSON (Proxy a) where

1209instance ToJSON (Proxy a) where

1064 toJSON _ = Null

1210 toJSON _ = Null

@@ -1072,6 +1218,7 @@ instance FromJSON (Proxy a) where

1072 parseJSON Null = pure Proxy

1218 parseJSON Null = pure Proxy

1073 parseJSON v = typeMismatch "Proxy" v

1219 parseJSON v = typeMismatch "Proxy" v

1074

1220

1221+

1075instance ToJSON1 (Tagged a) where

1222instance ToJSON1 (Tagged a) where

1076 liftToJSON to _ (Tagged x) = to x

1223 liftToJSON to _ (Tagged x) = to x

1077 {-# INLINE liftToJSON #-}

1224 {-# INLINE liftToJSON #-}

@@ -1094,35 +1241,19 @@ instance FromJSON b => FromJSON (Tagged a b) where

1094 parseJSON = parseJSON1

1241 parseJSON = parseJSON1

1095 {-# INLINE parseJSON #-}

1242 {-# INLINE parseJSON #-}

1096

1243

1097−instance ToJSON a => ToJSON (Const a b) where

1244+instance FromJSONKey b => FromJSONKey (Tagged a b) where

1098− toJSON (Const x) = toJSON x

1245+ fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)

1099− {-# INLINE toJSON #-}

1246+ fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList

1100−

1101− toEncoding (Const x) = toEncoding x

1102− {-# INLINE toEncoding #-}

1103

1247

1104−instance FromJSON a => FromJSON (Const a b) where

1248+instance ToJSONKey b => ToJSONKey (Tagged a b) where

1105− {-# INLINE parseJSON #-}

1249+ toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey

1106− parseJSON = fmap Const . parseJSON

1250+ toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList

1107

1251

1108−--------------------------------------------

1252+-------------------------------------------------------------------------------

1109-- Instances for converting to/from map keys

1253-- Instances for converting to/from map keys

1110−--------------------------------------------

1254+-------------------------------------------------------------------------------

1111−class ToJSONKey a where

1255+

1112− toJSONKey :: ToJSONKeyFunction a

1256+

1113− default toJSONKey :: ToJSON a => ToJSONKeyFunction a

1114− toJSONKey = ToJSONKeyValue (toJSON, toEncoding)

1115− toJSONKeyList :: ToJSONKeyFunction [a]

1116− default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]

1117− toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)

1118−

1119−class FromJSONKey a where

1120− fromJSONKey :: FromJSONKeyFunction a

1121− default fromJSONKey :: FromJSON a => FromJSONKeyFunction a

1122− fromJSONKey = FromJSONKeyValue parseJSON

1123− fromJSONKeyList :: FromJSONKeyFunction [a]

1124− default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]

1125− fromJSONKeyList = FromJSONKeyValue parseJSON

1126

1257

1127instance ToJSONKey Text where

1258instance ToJSONKey Text where

1128 toJSONKey = ToJSONKeyText (id,toEncoding)

1259 toJSONKey = ToJSONKeyText (id,toEncoding)

@@ -1130,10 +1261,7 @@ instance ToJSONKey Text where

1130instance FromJSONKey Text where

1261instance FromJSONKey Text where

1131 fromJSONKey = fromJSONKeyCoerce

1262 fromJSONKey = fromJSONKeyCoerce

1132

1263

1133−-- | TODO: where ToJSONKey instance

1264+

1134−instance FromJSONKey b => FromJSONKey (Tagged a b) where

1135− fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)

1136− fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList

1137

1265

1138instance ToJSONKey Bool where

1266instance ToJSONKey Bool where

1139 toJSONKey = ToJSONKeyText

1267 toJSONKey = ToJSONKeyText

@@ -1187,7 +1315,9 @@ instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where

1187instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where

1315instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where

1188 fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey

1316 fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey

1189

1317

1190−

1318+-------------------------------------------------------------------------------

1319+-- Functions

1320+-------------------------------------------------------------------------------

1191

1321

1192-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@

1322-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@

1193-- and fails using @'typeMismatch' expected@ otherwise.

1323-- and fails using @'typeMismatch' expected@ otherwise.

@@ -1310,34 +1440,3 @@ obj .:! key = case H.lookup key obj of

1310(.!=) :: Parser (Maybe a) -> a -> Parser a

1440(.!=) :: Parser (Maybe a) -> a -> Parser a

1311pmval .!= val = fromMaybe val <$> pmval

1441pmval .!= val = fromMaybe val <$> pmval

1312{-# INLINE (.!=) #-}

1442{-# INLINE (.!=) #-}

1313−

1314−realFloatToJSON :: RealFloat a => a -> Value

1315−realFloatToJSON d

1316− | isNaN d || isInfinite d = Null

1317− | otherwise = Number $ Scientific.fromFloatDigits d

1318−{-# INLINE realFloatToJSON #-}

1319−

1320−realFloatToEncoding :: RealFloat a => a -> Encoding

1321−realFloatToEncoding d

1322− | isNaN d || isInfinite d = Encoding E.null_

1323− | otherwise = toEncoding (Scientific.fromFloatDigits d)

1324−{-# INLINE realFloatToEncoding #-}

1325−

1326−scientificToNumber :: Scientific -> Number

1327−scientificToNumber s

1328− | e < 0 = D $ Scientific.toRealFloat s

1329− | otherwise = I $ c * 10 ^ e

1330− where

1331− e = Scientific.base10Exponent s

1332− c = Scientific.coefficient s

1333−{-# INLINE scientificToNumber #-}

1334−

1335−parseRealFloat :: RealFloat a => String -> Value -> Parser a

1336−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s

1337−parseRealFloat _ Null = pure (0/0)

1338−parseRealFloat expected v = typeMismatch expected v

1339−{-# INLINE parseRealFloat #-}

1340−

1341−parseIntegral :: Integral a => String -> Value -> Parser a

1342−parseIntegral expected = withScientific expected $ pure . truncate

1343−{-# INLINE parseIntegral #-}