260a7e8 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Separate class definitions from instances

260a7e8Bryan O'Sullivan13 years ago

Data/Aeson/Types.hs+1−1

compare with master

unifiedsplit

@@ -63,7 +63,7 @@ module Data.Aeson.Types

63 , defaultTaggedObject

64 ) where

66−import Data.Aeson.Types.Class

66+import Data.Aeson.Types.Instances

67import Data.Aeson.Types.Internal

69#ifdef GENERICS

Data/Aeson/Types/Class.hs+2−746

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

1−{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,

1+{-# LANGUAGE CPP, FlexibleContexts #-}

2− GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,

3− OverloadedStrings, UndecidableInstances, ViewPatterns #-}

4−{-# OPTIONS_GHC -fno-warn-orphans #-}

6#ifdef GENERICS

3#ifdef GENERICS

7{-# LANGUAGE DefaultSignatures #-}

4{-# LANGUAGE DefaultSignatures #-}

@@ -9,7 +6,7 @@

10-- |

7-- |

11-- Module: Data.Aeson.Types.Class

8-- Module: Data.Aeson.Types.Class

14-- License: Apache

11-- License: Apache

15-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

12-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

@@ -31,59 +28,9 @@ module Data.Aeson.Types.Class

31 , genericToJSON

28 , genericToJSON

32 , genericParseJSON

29 , genericParseJSON

33#endif

30#endif

34− -- * Types

35− , DotNetTime(..)

36−

37− -- * Inspecting @'Value's@

38− , withObject

39− , withText

40− , withArray

41− , withNumber

42− , withBool

43−

44− -- * Functions

45− , fromJSON

46− , (.:)

47− , (.:?)

48− , (.!=)

49− , (.=)

50− , typeMismatch

51 ) where

31 ) where

53−import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)

54−import Data.Aeson.Functions

55import Data.Aeson.Types.Internal

33import Data.Aeson.Types.Internal

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

57−import Data.Fixed

58−import Data.Hashable (Hashable(..))

59−import Data.Int (Int8, Int16, Int32, Int64)

60−import Data.Maybe (fromMaybe)

61−import Data.Monoid (Dual(..), First(..), Last(..), mappend)

62−import Data.Ratio (Ratio)

63−import Data.Text (Text, pack, unpack)

64−import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))

65−import Data.Time.Format (FormatTime, formatTime, parseTime)

66−import Data.Traversable (traverse)

67−import Data.Typeable (Typeable)

68−import Data.Vector (Vector)

69−import Data.Word (Word, Word8, Word16, Word32, Word64)

70−import Foreign.Storable (Storable)

71−import System.Locale (defaultTimeLocale, dateTimeFmt)

72−import qualified Data.HashMap.Strict as H

73−import qualified Data.HashSet as HashSet

74−import qualified Data.IntMap as IntMap

75−import qualified Data.IntSet as IntSet

76−import qualified Data.Map as M

77−import qualified Data.Set as Set

78−import qualified Data.Tree as Tree

79−import qualified Data.Text as T

80−import qualified Data.Text.Lazy as LT

81−import qualified Data.Vector as V

82−import qualified Data.Vector.Generic as VG

83−import qualified Data.Vector.Primitive as VP

84−import qualified Data.Vector.Storable as VS

85−import qualified Data.Vector.Unboxed as VU

86−import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )

88#ifdef GENERICS

35#ifdef GENERICS

89import GHC.Generics

36import GHC.Generics

@@ -243,694 +190,3 @@ class FromJSON a where

243 default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a

190 default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a

244 parseJSON = genericParseJSON defaultOptions

191 parseJSON = genericParseJSON defaultOptions

245#endif

192#endif

246−

247−instance (ToJSON a) => ToJSON (Maybe a) where

248− toJSON (Just a) = toJSON a

249− toJSON Nothing = Null

250− {-# INLINE toJSON #-}

251−

252−instance (FromJSON a) => FromJSON (Maybe a) where

253− parseJSON Null = pure Nothing

254− parseJSON a = Just <$> parseJSON a

255− {-# INLINE parseJSON #-}

256−

257−instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where

258− toJSON (Left a) = object [left .= a]

259− toJSON (Right b) = object [right .= b]

260− {-# INLINE toJSON #-}

261−

262−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where

263− parseJSON (Object (H.toList -> [(key, value)]))

264− | key == left = Left <$> parseJSON value

265− | key == right = Right <$> parseJSON value

266− parseJSON _ = fail ""

267− {-# INLINE parseJSON #-}

268−

269−left, right :: Text

270−left = "Left"

271−right = "Right"

272−

273−instance ToJSON Bool where

274− toJSON = Bool

275− {-# INLINE toJSON #-}

276−

277−instance FromJSON Bool where

278− parseJSON = withBool "Bool" pure

279− {-# INLINE parseJSON #-}

280−

281−instance ToJSON () where

282− toJSON _ = emptyArray

283− {-# INLINE toJSON #-}

284−

285−instance FromJSON () where

286− parseJSON = withArray "()" $ \v ->

287− if V.null v

288− then pure ()

289− else fail "Expected an empty array"

290− {-# INLINE parseJSON #-}

291−

292−instance ToJSON [Char] where

293− toJSON = String . T.pack

294− {-# INLINE toJSON #-}

295−

296−instance FromJSON [Char] where

297− parseJSON = withText "String" $ pure . T.unpack

298− {-# INLINE parseJSON #-}

299−

300−instance ToJSON Char where

301− toJSON = String . T.singleton

302− {-# INLINE toJSON #-}

303−

304−instance FromJSON Char where

305− parseJSON = withText "Char" $ \t ->

306− if T.compareLength t 1 == EQ

307− then pure $ T.head t

308− else fail "Expected a string of length 1"

309− {-# INLINE parseJSON #-}

310−

311−instance ToJSON Double where

312− toJSON = Number . D

313− {-# INLINE toJSON #-}

314−

315−instance FromJSON Double where

316− parseJSON (Number n) = case n of

317− D d -> pure d

318− I i -> pure (fromIntegral i)

319− parseJSON Null = pure (0/0)

320− parseJSON v = typeMismatch "Double" v

321− {-# INLINE parseJSON #-}

322−

323−instance ToJSON Number where

324− toJSON = Number

325− {-# INLINE toJSON #-}

326−

327−instance FromJSON Number where

328− parseJSON (Number n) = pure n

329− parseJSON Null = pure (D (0/0))

330− parseJSON v = typeMismatch "Number" v

331− {-# INLINE parseJSON #-}

332−

333−instance ToJSON Float where

334− toJSON = Number . realToFrac

335− {-# INLINE toJSON #-}

336−

337−instance FromJSON Float where

338− parseJSON (Number n) = pure $ case n of

339− D d -> realToFrac d

340− I i -> fromIntegral i

341− parseJSON Null = pure (0/0)

342− parseJSON v = typeMismatch "Float" v

343− {-# INLINE parseJSON #-}

344−

345−instance ToJSON (Ratio Integer) where

346− toJSON = Number . fromRational

347− {-# INLINE toJSON #-}

348−

349−instance FromJSON (Ratio Integer) where

350− parseJSON = withNumber "Ration Integer" $ \n ->

351− pure $ case n of

352− D d -> toRational d

353− I i -> fromIntegral i

354− {-# INLINE parseJSON #-}

355−

356−instance HasResolution a => ToJSON (Fixed a) where

357− toJSON = Number . realToFrac

358− {-# INLINE toJSON #-}

359−

360−instance HasResolution a => FromJSON (Fixed a) where

361− parseJSON (Number n) = pure $ case n of

362− D d -> realToFrac d

363− I i -> fromIntegral i

364− parseJSON v = typeMismatch "Fixed" v

365− {-# INLINE parseJSON #-}

366−

367−instance ToJSON Int where

368− toJSON = Number . fromIntegral

369− {-# INLINE toJSON #-}

370−

371−instance FromJSON Int where

372− parseJSON = parseIntegral

373− {-# INLINE parseJSON #-}

374−

375−parseIntegral :: Integral a => Value -> Parser a

376−parseIntegral = withNumber "Integral" $ pure . floor

377−{-# INLINE parseIntegral #-}

378−

379−instance ToJSON Integer where

380− toJSON = Number . fromIntegral

381− {-# INLINE toJSON #-}

382−

383−instance FromJSON Integer where

384− parseJSON = parseIntegral

385− {-# INLINE parseJSON #-}

386−

387−instance ToJSON Int8 where

388− toJSON = Number . fromIntegral

389− {-# INLINE toJSON #-}

390−

391−instance FromJSON Int8 where

392− parseJSON = parseIntegral

393− {-# INLINE parseJSON #-}

394−

395−instance ToJSON Int16 where

396− toJSON = Number . fromIntegral

397− {-# INLINE toJSON #-}

398−

399−instance FromJSON Int16 where

400− parseJSON = parseIntegral

401− {-# INLINE parseJSON #-}

402−

403−instance ToJSON Int32 where

404− toJSON = Number . fromIntegral

405− {-# INLINE toJSON #-}

406−

407−instance FromJSON Int32 where

408− parseJSON = parseIntegral

409− {-# INLINE parseJSON #-}

410−

411−instance ToJSON Int64 where

412− toJSON = Number . fromIntegral

413− {-# INLINE toJSON #-}

414−

415−instance FromJSON Int64 where

416− parseJSON = parseIntegral

417− {-# INLINE parseJSON #-}

418−

419−instance ToJSON Word where

420− toJSON = Number . fromIntegral

421− {-# INLINE toJSON #-}

422−

423−instance FromJSON Word where

424− parseJSON = parseIntegral

425− {-# INLINE parseJSON #-}

426−

427−instance ToJSON Word8 where

428− toJSON = Number . fromIntegral

429− {-# INLINE toJSON #-}

430−

431−instance FromJSON Word8 where

432− parseJSON = parseIntegral

433− {-# INLINE parseJSON #-}

434−

435−instance ToJSON Word16 where

436− toJSON = Number . fromIntegral

437− {-# INLINE toJSON #-}

438−

439−instance FromJSON Word16 where

440− parseJSON = parseIntegral

441− {-# INLINE parseJSON #-}

442−

443−instance ToJSON Word32 where

444− toJSON = Number . fromIntegral

445− {-# INLINE toJSON #-}

446−

447−instance FromJSON Word32 where

448− parseJSON = parseIntegral

449− {-# INLINE parseJSON #-}

450−

451−instance ToJSON Word64 where

452− toJSON = Number . fromIntegral

453− {-# INLINE toJSON #-}

454−

455−instance FromJSON Word64 where

456− parseJSON = parseIntegral

457− {-# INLINE parseJSON #-}

458−

459−instance ToJSON Text where

460− toJSON = String

461− {-# INLINE toJSON #-}

462−

463−instance FromJSON Text where

464− parseJSON = withText "Text" pure

465− {-# INLINE parseJSON #-}

466−

467−instance ToJSON LT.Text where

468− toJSON = String . LT.toStrict

469− {-# INLINE toJSON #-}

470−

471−instance FromJSON LT.Text where

472− parseJSON = withText "Lazy Text" $ pure . LT.fromStrict

473− {-# INLINE parseJSON #-}

474−

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

476− toJSON = Array . V.fromList . map toJSON

477− {-# INLINE toJSON #-}

478−

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

480− parseJSON = withArray "[a]" $ mapM parseJSON . V.toList

481− {-# INLINE parseJSON #-}

482−

483−instance (ToJSON a) => ToJSON (Vector a) where

484− toJSON = Array . V.map toJSON

485− {-# INLINE toJSON #-}

486−

487−instance (FromJSON a) => FromJSON (Vector a) where

488− parseJSON = withArray "Vector a" $ V.mapM parseJSON

489− {-# INLINE parseJSON #-}

490−

491−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value

492−vectorToJSON = Array . V.map toJSON . V.convert

493−{-# INLINE vectorToJSON #-}

494−

495−vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)

496−vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON

497−{-# INLINE vectorParseJSON #-}

498−

499−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where

500− toJSON = vectorToJSON

501−

502−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where

503− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"

504−

505−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where

506− toJSON = vectorToJSON

507−

508−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where

509− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"

510−

511−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where

512− toJSON = vectorToJSON

513−

514−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where

515− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

516−

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

518− toJSON = toJSON . Set.toList

519− {-# INLINE toJSON #-}

520−

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

522− parseJSON = fmap Set.fromList . parseJSON

523− {-# INLINE parseJSON #-}

524−

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

526− toJSON = toJSON . HashSet.toList

527− {-# INLINE toJSON #-}

528−

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

530− parseJSON = fmap HashSet.fromList . parseJSON

531− {-# INLINE parseJSON #-}

532−

533−instance ToJSON IntSet.IntSet where

534− toJSON = toJSON . IntSet.toList

535− {-# INLINE toJSON #-}

536−

537−instance FromJSON IntSet.IntSet where

538− parseJSON = fmap IntSet.fromList . parseJSON

539− {-# INLINE parseJSON #-}

540−

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

542− toJSON = toJSON . IntMap.toList

543− {-# INLINE toJSON #-}

544−

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

546− parseJSON = fmap IntMap.fromList . parseJSON

547− {-# INLINE parseJSON #-}

548−

549−instance (ToJSON v) => ToJSON (M.Map Text v) where

550− toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty

551− {-# INLINE toJSON #-}

552−

553−instance (FromJSON v) => FromJSON (M.Map Text v) where

554− parseJSON = withObject "Map Text a" $

555− fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON

556−

557−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where

558− toJSON = Object . mapHashKeyVal LT.toStrict toJSON

559−

560−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where

561− parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON

562−

563−instance (ToJSON v) => ToJSON (M.Map String v) where

564− toJSON = Object . mapHashKeyVal pack toJSON

565−

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

567− parseJSON = fmap (hashMapKey unpack) . parseJSON

568−

569−instance (ToJSON v) => ToJSON (H.HashMap Text v) where

570− toJSON = Object . H.map toJSON

571− {-# INLINE toJSON #-}

572−

573−instance (FromJSON v) => FromJSON (H.HashMap Text v) where

574− parseJSON = withObject "HashMap Text a" $ traverse parseJSON

575−

576−instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where

577− toJSON = Object . mapKeyVal LT.toStrict toJSON

578−

579−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where

580− parseJSON = fmap (mapKey LT.fromStrict) . parseJSON

581−

582−instance (ToJSON v) => ToJSON (H.HashMap String v) where

583− toJSON = Object . mapKeyVal pack toJSON

584−

585−instance (FromJSON v) => FromJSON (H.HashMap String v) where

586− parseJSON = fmap (mapKey unpack) . parseJSON

587−

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

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

590−

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

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

593−

594−instance ToJSON Value where

595− toJSON a = a

596− {-# INLINE toJSON #-}

597−

598−instance FromJSON Value where

599− parseJSON a = pure a

600− {-# INLINE parseJSON #-}

601−

602−-- | A newtype wrapper for 'UTCTime' that uses the same non-standard

603−-- serialization format as Microsoft .NET, whose @System.DateTime@

604−-- type is by default serialized to JSON as in the following example:

605−--

606−-- > /Date(1302547608878)/

607−--

608−-- The number represents milliseconds since the Unix epoch.

609−newtype DotNetTime = DotNetTime {

610− fromDotNetTime :: UTCTime

611− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)

612−

613−instance ToJSON DotNetTime where

614− toJSON (DotNetTime t) =

615− String (pack (secs ++ msecs ++ ")/"))

616− where secs = formatTime defaultTimeLocale "/Date(%s" t

617− msecs = take 3 $ formatTime defaultTimeLocale "%q" t

618− {-# INLINE toJSON #-}

619−

620−instance FromJSON DotNetTime where

621− parseJSON = withText "DotNetTime" $ \t ->

622− let (s,m) = T.splitAt (T.length t - 5) t

623− t' = T.concat [s,".",m]

624− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

625− Just d -> pure (DotNetTime d)

626− _ -> fail "could not parse .NET time"

627− {-# INLINE parseJSON #-}

628−

629−instance ToJSON ZonedTime where

630− toJSON t = String $ pack $ formatTime defaultTimeLocale format t

631− where

632− format = "%FT%T" ++ milliseconds ++ tzFormat

633− milliseconds = take 4 $ formatTime defaultTimeLocale "%Q" t

634− tzFormat

635− | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"

636− | otherwise = "%z"

637−

638−instance FromJSON ZonedTime where

639− parseJSON (String t) =

640− tryFormats alternateFormats

641− <|> fail "could not parse ECMA-262 ISO-8601 date"

642− where

643− tryFormat f =

644− case parseTime defaultTimeLocale f (unpack t) of

645− Just d -> pure d

646− Nothing -> empty

647− tryFormats = foldr1 (<|>) . map tryFormat

648− alternateFormats =

649− dateTimeFmt defaultTimeLocale :

650− distributeList ["%Y", "%Y-%m", "%F"]

651− ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]

652−

653− distributeList xs ys =

654− foldr (\x acc -> acc ++ distribute x ys) [] xs

655− distribute x = map (mappend x)

656−

657− parseJSON v = typeMismatch "ZonedTime" v

658−

659−instance ToJSON UTCTime where

660− toJSON t = String (pack (take 23 str ++ "Z"))

661− where str = formatTime defaultTimeLocale "%FT%T%Q" t

662− {-# INLINE toJSON #-}

663−

664−instance FromJSON UTCTime where

665− parseJSON = withText "UTCTime" $ \t ->

666− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of

667− Just d -> pure d

668− _ -> fail "could not parse ISO-8601 date"

669− {-# INLINE parseJSON #-}

670−

671−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where

672− toJSON (a,b) = Array $ V.create $ do

673− mv <- VM.unsafeNew 2

674− VM.unsafeWrite mv 0 (toJSON a)

675− VM.unsafeWrite mv 1 (toJSON b)

676− return mv

677− {-# INLINE toJSON #-}

678−

679−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where

680− parseJSON = withArray "(a,b)" $ \ab ->

681− let n = V.length ab

682− in if n == 2

683− then (,) <$> parseJSON (V.unsafeIndex ab 0)

684− <*> parseJSON (V.unsafeIndex ab 1)

685− else fail $ "cannot unpack array of length " ++

686− show n ++ " into a pair"

687− {-# INLINE parseJSON #-}

688−

689−instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where

690− toJSON (a,b,c) = Array $ V.create $ do

691− mv <- VM.unsafeNew 3

692− VM.unsafeWrite mv 0 (toJSON a)

693− VM.unsafeWrite mv 1 (toJSON b)

694− VM.unsafeWrite mv 2 (toJSON c)

695− return mv

696− {-# INLINE toJSON #-}

697−

698−instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where

699− parseJSON = withArray "(a,b,c)" $ \abc ->

700− let n = V.length abc

701− in if n == 3

702− then (,,) <$> parseJSON (V.unsafeIndex abc 0)

703− <*> parseJSON (V.unsafeIndex abc 1)

704− <*> parseJSON (V.unsafeIndex abc 2)

705− else fail $ "cannot unpack array of length " ++

706− show n ++ " into a 3-tuple"

707− {-# INLINE parseJSON #-}

708−

709−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where

710− toJSON (a,b,c,d) = Array $ V.create $ do

711− mv <- VM.unsafeNew 4

712− VM.unsafeWrite mv 0 (toJSON a)

713− VM.unsafeWrite mv 1 (toJSON b)

714− VM.unsafeWrite mv 2 (toJSON c)

715− VM.unsafeWrite mv 3 (toJSON d)

716− return mv

717− {-# INLINE toJSON #-}

718−

719−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where

720− parseJSON = withArray "(a,b,c,d)" $ \abcd ->

721− let n = V.length abcd

722− in if n == 4

723− then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)

724− <*> parseJSON (V.unsafeIndex abcd 1)

725− <*> parseJSON (V.unsafeIndex abcd 2)

726− <*> parseJSON (V.unsafeIndex abcd 3)

727− else fail $ "cannot unpack array of length " ++

728− show n ++ " into a 4-tuple"

729− {-# INLINE parseJSON #-}

730−

731−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a,b,c,d,e) where

732− toJSON (a,b,c,d,e) = Array $ V.create $ do

733− mv <- VM.unsafeNew 5

734− VM.unsafeWrite mv 0 (toJSON a)

735− VM.unsafeWrite mv 1 (toJSON b)

736− VM.unsafeWrite mv 2 (toJSON c)

737− VM.unsafeWrite mv 3 (toJSON d)

738− VM.unsafeWrite mv 4 (toJSON e)

739− return mv

740− {-# INLINE toJSON #-}

741−

742−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a,b,c,d,e) where

743− parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->

744− let n = V.length abcde

745− in if n == 5

746− then (,,,,) <$> parseJSON (V.unsafeIndex abcde 0)

747− <*> parseJSON (V.unsafeIndex abcde 1)

748− <*> parseJSON (V.unsafeIndex abcde 2)

749− <*> parseJSON (V.unsafeIndex abcde 3)

750− <*> parseJSON (V.unsafeIndex abcde 4)

751− else fail $ "cannot unpack array of length " ++

752− show n ++ " into a 5-tuple"

753− {-# INLINE parseJSON #-}

754−

755−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a,b,c,d,e,f) where

756− toJSON (a,b,c,d,e,f) = Array $ V.create $ do

757− mv <- VM.unsafeNew 6

758− VM.unsafeWrite mv 0 (toJSON a)

759− VM.unsafeWrite mv 1 (toJSON b)

760− VM.unsafeWrite mv 2 (toJSON c)

761− VM.unsafeWrite mv 3 (toJSON d)

762− VM.unsafeWrite mv 4 (toJSON e)

763− VM.unsafeWrite mv 5 (toJSON f)

764− return mv

765− {-# INLINE toJSON #-}

766−

767−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a,b,c,d,e,f) where

768− parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->

769− let n = V.length abcdef

770− in if n == 6

771− then (,,,,,) <$> parseJSON (V.unsafeIndex abcdef 0)

772− <*> parseJSON (V.unsafeIndex abcdef 1)

773− <*> parseJSON (V.unsafeIndex abcdef 2)

774− <*> parseJSON (V.unsafeIndex abcdef 3)

775− <*> parseJSON (V.unsafeIndex abcdef 4)

776− <*> parseJSON (V.unsafeIndex abcdef 5)

777− else fail $ "cannot unpack array of length " ++

778− show n ++ " into a 6-tuple"

779− {-# INLINE parseJSON #-}

780−

781−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a,b,c,d,e,f,g) where

782− toJSON (a,b,c,d,e,f,g) = Array $ V.create $ do

783− mv <- VM.unsafeNew 7

784− VM.unsafeWrite mv 0 (toJSON a)

785− VM.unsafeWrite mv 1 (toJSON b)

786− VM.unsafeWrite mv 2 (toJSON c)

787− VM.unsafeWrite mv 3 (toJSON d)

788− VM.unsafeWrite mv 4 (toJSON e)

789− VM.unsafeWrite mv 5 (toJSON f)

790− VM.unsafeWrite mv 6 (toJSON g)

791− return mv

792− {-# INLINE toJSON #-}

793−

794−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where

795− parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->

796− let n = V.length abcdefg

797− in if n == 7

798− then (,,,,,,) <$> parseJSON (V.unsafeIndex abcdefg 0)

799− <*> parseJSON (V.unsafeIndex abcdefg 1)

800− <*> parseJSON (V.unsafeIndex abcdefg 2)

801− <*> parseJSON (V.unsafeIndex abcdefg 3)

802− <*> parseJSON (V.unsafeIndex abcdefg 4)

803− <*> parseJSON (V.unsafeIndex abcdefg 5)

804− <*> parseJSON (V.unsafeIndex abcdefg 6)

805− else fail $ "cannot unpack array of length " ++

806− show n ++ " into a 7-tuple"

807− {-# INLINE parseJSON #-}

808−

809−instance ToJSON a => ToJSON (Dual a) where

810− toJSON = toJSON . getDual

811− {-# INLINE toJSON #-}

812−

813−instance FromJSON a => FromJSON (Dual a) where

814− parseJSON = fmap Dual . parseJSON

815− {-# INLINE parseJSON #-}

816−

817−instance ToJSON a => ToJSON (First a) where

818− toJSON = toJSON . getFirst

819− {-# INLINE toJSON #-}

820−

821−instance FromJSON a => FromJSON (First a) where

822− parseJSON = fmap First . parseJSON

823− {-# INLINE parseJSON #-}

824−

825−instance ToJSON a => ToJSON (Last a) where

826− toJSON = toJSON . getLast

827− {-# INLINE toJSON #-}

828−

829−instance FromJSON a => FromJSON (Last a) where

830− parseJSON = fmap Last . parseJSON

831− {-# INLINE parseJSON #-}

832−

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

834−-- and fails using @'typeMismatch' expected@ otherwise.

835−withObject :: String -> (Object -> Parser a) -> Value -> Parser a

836−withObject _ f (Object obj) = f obj

837−withObject expected _ v = typeMismatch expected v

838−{-# INLINE withObject #-}

839−

840−-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@

841−-- and fails using @'typeMismatch' expected@ otherwise.

842−withText :: String -> (Text -> Parser a) -> Value -> Parser a

843−withText _ f (String txt) = f txt

844−withText expected _ v = typeMismatch expected v

845−{-# INLINE withText #-}

846−

847−-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@

848−-- and fails using @'typeMismatch' expected@ otherwise.

849−withArray :: String -> (Array -> Parser a) -> Value -> Parser a

850−withArray _ f (Array arr) = f arr

851−withArray expected _ v = typeMismatch expected v

852−{-# INLINE withArray #-}

853−

854−-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@

855−-- and fails using @'typeMismatch' expected@ otherwise.

856−withNumber :: String -> (Number -> Parser a) -> Value -> Parser a

857−withNumber _ f (Number num) = f num

858−withNumber expected _ v = typeMismatch expected v

859−{-# INLINE withNumber #-}

860−

861−-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@

862−-- and fails using @'typeMismatch' expected@ otherwise.

863−withBool :: String -> (Bool -> Parser a) -> Value -> Parser a

864−withBool _ f (Bool arr) = f arr

865−withBool expected _ v = typeMismatch expected v

866−{-# INLINE withBool #-}

867−

868−-- | Construct a 'Pair' from a key and a value.

869−(.=) :: ToJSON a => Text -> a -> Pair

870−name .= value = (name, toJSON value)

871−{-# INLINE (.=) #-}

872−

873−-- | Convert a value from JSON, failing if the types do not match.

874−fromJSON :: (FromJSON a) => Value -> Result a

875−fromJSON = parse parseJSON

876−{-# INLINE fromJSON #-}

877−

878−-- | Retrieve the value associated with the given key of an 'Object'.

879−-- The result is 'empty' if the key is not present or the value cannot

880−-- be converted to the desired type.

881−--

882−-- This accessor is appropriate if the key and value /must/ be present

883−-- in an object for it to be valid. If the key and value are

884−-- optional, use '(.:?)' instead.

885−(.:) :: (FromJSON a) => Object -> Text -> Parser a

886−obj .: key = case H.lookup key obj of

887− Nothing -> fail $ "key " ++ show key ++ " not present"

888− Just v -> parseJSON v

889−{-# INLINE (.:) #-}

890−

891−-- | Retrieve the value associated with the given key of an 'Object'.

892−-- The result is 'Nothing' if the key is not present, or 'empty' if

893−-- the value cannot be converted to the desired type.

894−--

895−-- This accessor is most useful if the key and value can be absent

896−-- from an object without affecting its validity. If the key and

897−-- value are mandatory, use '(.:)' instead.

898−(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

899−obj .:? key = case H.lookup key obj of

900− Nothing -> pure Nothing

901− Just v -> parseJSON v

902−{-# INLINE (.:?) #-}

903−

904−-- | Helper for use in combination with '.:?' to provide default

905−-- values for optional JSON object fields.

906−--

907−-- This combinator is most useful if the key and value can be absent

908−-- from an object without affecting its validity and we know a default

909−-- value to assign in that case. If the key and value are mandatory,

910−-- use '(.:)' instead.

911−--

912−-- Example usage:

913−--

914−-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"

915−-- v2 <- o '.:' \"mandatory_field\"

916−-- v3 <- o '.:?' \"opt_field2\"

917−-- @

918−(.!=) :: Parser (Maybe a) -> a -> Parser a

919−pmval .!= val = fromMaybe val <$> pmval

920−{-# INLINE (.!=) #-}

921−

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

923−typeMismatch :: String -- ^ The name of the type you are trying to parse.

924− -> Value -- ^ The actual value encountered.

925− -> Parser a

926−typeMismatch expected actual =

927− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++

928− " instead"

929− where

930− name = case actual of

931− Object _ -> "Object"

932− Array _ -> "Array"

933− String _ -> "String"

934− Number _ -> "Number"

935− Bool _ -> "Boolean"

936− Null -> "Null"

Data/Aeson/Types/Generic.hs+1−1

@@ -22,7 +22,7 @@ module Data.Aeson.Types.Generic ( ) where

22import Control.Applicative ((<*>), (<$>), (<|>), pure)

23import Control.Monad ((<=<))

24import Control.Monad.ST (ST)

25−import Data.Aeson.Types.Class

25+import Data.Aeson.Types.Instances

26import Data.Aeson.Types.Internal

27import Data.Bits

28import Data.DList (DList, toList, empty)

Data/Aeson/Types/Instances.hsnew file+766

@@ -0,0 +1,766 @@

1+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,

2+ IncoherentInstances, OverlappingInstances,

3+ OverloadedStrings, UndecidableInstances, ViewPatterns #-}

4+{-# OPTIONS_GHC -fno-warn-orphans #-}

6+#ifdef GENERICS

7+{-# LANGUAGE DefaultSignatures #-}

8+#endif

10+-- |

11+-- Module: Data.Aeson.Types.Instances

14+-- License: Apache

15+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>

16+-- Stability: experimental

17+-- Portability: portable

18+--

19+-- Types for working with JSON data.

20+

21+module Data.Aeson.Types.Instances

22+ (

23+ -- * Type classes

24+ -- ** Core JSON classes

25+ FromJSON(..)

26+ , ToJSON(..)

27+#ifdef GENERICS

28+ -- ** Generic JSON classes

29+ , GFromJSON(..)

30+ , GToJSON(..)

31+ , genericToJSON

32+ , genericParseJSON

33+#endif

34+ -- * Types

35+ , DotNetTime(..)

36+

37+ -- * Inspecting @'Value's@

38+ , withObject

39+ , withText

40+ , withArray

41+ , withNumber

42+ , withBool

43+

44+ -- * Functions

45+ , fromJSON

46+ , (.:)

47+ , (.:?)

48+ , (.!=)

49+ , (.=)

50+ , typeMismatch

51+ ) where

52+

53+import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)

54+import Data.Aeson.Functions

55+import Data.Aeson.Types.Class

56+import Data.Aeson.Types.Internal

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

58+import Data.Fixed

59+import Data.Hashable (Hashable(..))

60+import Data.Int (Int8, Int16, Int32, Int64)

61+import Data.Maybe (fromMaybe)

62+import Data.Monoid (Dual(..), First(..), Last(..), mappend)

63+import Data.Ratio (Ratio)

64+import Data.Text (Text, pack, unpack)

65+import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))

66+import Data.Time.Format (formatTime, parseTime)

67+import Data.Traversable (traverse)

68+import Data.Vector (Vector)

69+import Data.Word (Word, Word8, Word16, Word32, Word64)

70+import Foreign.Storable (Storable)

71+import System.Locale (defaultTimeLocale, dateTimeFmt)

72+import qualified Data.HashMap.Strict as H

73+import qualified Data.HashSet as HashSet

74+import qualified Data.IntMap as IntMap

75+import qualified Data.IntSet as IntSet

76+import qualified Data.Map as M

77+import qualified Data.Set as Set

78+import qualified Data.Tree as Tree

79+import qualified Data.Text as T

80+import qualified Data.Text.Lazy as LT

81+import qualified Data.Vector as V

82+import qualified Data.Vector.Generic as VG

83+import qualified Data.Vector.Primitive as VP

84+import qualified Data.Vector.Storable as VS

85+import qualified Data.Vector.Unboxed as VU

86+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )

87+

88+instance (ToJSON a) => ToJSON (Maybe a) where

89+ toJSON (Just a) = toJSON a

90+ toJSON Nothing = Null

91+ {-# INLINE toJSON #-}

92+

93+instance (FromJSON a) => FromJSON (Maybe a) where

94+ parseJSON Null = pure Nothing

95+ parseJSON a = Just <$> parseJSON a

96+ {-# INLINE parseJSON #-}

97+

98+instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where

99+ toJSON (Left a) = object [left .= a]

100+ toJSON (Right b) = object [right .= b]

101+ {-# INLINE toJSON #-}

102+

103+instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where

104+ parseJSON (Object (H.toList -> [(key, value)]))

105+ | key == left = Left <$> parseJSON value

106+ | key == right = Right <$> parseJSON value

107+ parseJSON _ = fail ""

108+ {-# INLINE parseJSON #-}

109+

110+left, right :: Text

111+left = "Left"

112+right = "Right"

113+

114+instance ToJSON Bool where

115+ toJSON = Bool

116+ {-# INLINE toJSON #-}

117+

118+instance FromJSON Bool where

119+ parseJSON = withBool "Bool" pure

120+ {-# INLINE parseJSON #-}

121+

122+instance ToJSON () where

123+ toJSON _ = emptyArray

124+ {-# INLINE toJSON #-}

125+

126+instance FromJSON () where

127+ parseJSON = withArray "()" $ \v ->

128+ if V.null v

129+ then pure ()

130+ else fail "Expected an empty array"

131+ {-# INLINE parseJSON #-}

132+

133+instance ToJSON [Char] where

134+ toJSON = String . T.pack

135+ {-# INLINE toJSON #-}

136+

137+instance FromJSON [Char] where

138+ parseJSON = withText "String" $ pure . T.unpack

139+ {-# INLINE parseJSON #-}

140+

141+instance ToJSON Char where

142+ toJSON = String . T.singleton

143+ {-# INLINE toJSON #-}

144+

145+instance FromJSON Char where

146+ parseJSON = withText "Char" $ \t ->

147+ if T.compareLength t 1 == EQ

148+ then pure $ T.head t

149+ else fail "Expected a string of length 1"

150+ {-# INLINE parseJSON #-}

151+

152+instance ToJSON Double where

153+ toJSON = Number . D

154+ {-# INLINE toJSON #-}

155+

156+instance FromJSON Double where

157+ parseJSON (Number n) = case n of

158+ D d -> pure d

159+ I i -> pure (fromIntegral i)

160+ parseJSON Null = pure (0/0)

161+ parseJSON v = typeMismatch "Double" v

162+ {-# INLINE parseJSON #-}

163+

164+instance ToJSON Number where

165+ toJSON = Number

166+ {-# INLINE toJSON #-}

167+

168+instance FromJSON Number where

169+ parseJSON (Number n) = pure n

170+ parseJSON Null = pure (D (0/0))

171+ parseJSON v = typeMismatch "Number" v

172+ {-# INLINE parseJSON #-}

173+

174+instance ToJSON Float where

175+ toJSON = Number . realToFrac

176+ {-# INLINE toJSON #-}

177+

178+instance FromJSON Float where

179+ parseJSON (Number n) = pure $ case n of

180+ D d -> realToFrac d

181+ I i -> fromIntegral i

182+ parseJSON Null = pure (0/0)

183+ parseJSON v = typeMismatch "Float" v

184+ {-# INLINE parseJSON #-}

185+

186+instance ToJSON (Ratio Integer) where

187+ toJSON = Number . fromRational

188+ {-# INLINE toJSON #-}

189+

190+instance FromJSON (Ratio Integer) where

191+ parseJSON = withNumber "Ration Integer" $ \n ->

192+ pure $ case n of

193+ D d -> toRational d

194+ I i -> fromIntegral i

195+ {-# INLINE parseJSON #-}

196+

197+instance HasResolution a => ToJSON (Fixed a) where

198+ toJSON = Number . realToFrac

199+ {-# INLINE toJSON #-}

200+

201+instance HasResolution a => FromJSON (Fixed a) where

202+ parseJSON (Number n) = pure $ case n of

203+ D d -> realToFrac d

204+ I i -> fromIntegral i

205+ parseJSON v = typeMismatch "Fixed" v

206+ {-# INLINE parseJSON #-}

207+

208+instance ToJSON Int where

209+ toJSON = Number . fromIntegral

210+ {-# INLINE toJSON #-}

211+

212+instance FromJSON Int where

213+ parseJSON = parseIntegral

214+ {-# INLINE parseJSON #-}

215+

216+parseIntegral :: Integral a => Value -> Parser a

217+parseIntegral = withNumber "Integral" $ pure . floor

218+{-# INLINE parseIntegral #-}

219+

220+instance ToJSON Integer where

221+ toJSON = Number . fromIntegral

222+ {-# INLINE toJSON #-}

223+

224+instance FromJSON Integer where

225+ parseJSON = parseIntegral

226+ {-# INLINE parseJSON #-}

227+

228+instance ToJSON Int8 where

229+ toJSON = Number . fromIntegral

230+ {-# INLINE toJSON #-}

231+

232+instance FromJSON Int8 where

233+ parseJSON = parseIntegral

234+ {-# INLINE parseJSON #-}

235+

236+instance ToJSON Int16 where

237+ toJSON = Number . fromIntegral

238+ {-# INLINE toJSON #-}

239+

240+instance FromJSON Int16 where

241+ parseJSON = parseIntegral

242+ {-# INLINE parseJSON #-}

243+

244+instance ToJSON Int32 where

245+ toJSON = Number . fromIntegral

246+ {-# INLINE toJSON #-}

247+

248+instance FromJSON Int32 where

249+ parseJSON = parseIntegral

250+ {-# INLINE parseJSON #-}

251+

252+instance ToJSON Int64 where

253+ toJSON = Number . fromIntegral

254+ {-# INLINE toJSON #-}

255+

256+instance FromJSON Int64 where

257+ parseJSON = parseIntegral

258+ {-# INLINE parseJSON #-}

259+

260+instance ToJSON Word where

261+ toJSON = Number . fromIntegral

262+ {-# INLINE toJSON #-}

263+

264+instance FromJSON Word where

265+ parseJSON = parseIntegral

266+ {-# INLINE parseJSON #-}

267+

268+instance ToJSON Word8 where

269+ toJSON = Number . fromIntegral

270+ {-# INLINE toJSON #-}

271+

272+instance FromJSON Word8 where

273+ parseJSON = parseIntegral

274+ {-# INLINE parseJSON #-}

275+

276+instance ToJSON Word16 where

277+ toJSON = Number . fromIntegral

278+ {-# INLINE toJSON #-}

279+

280+instance FromJSON Word16 where

281+ parseJSON = parseIntegral

282+ {-# INLINE parseJSON #-}

283+

284+instance ToJSON Word32 where

285+ toJSON = Number . fromIntegral

286+ {-# INLINE toJSON #-}

287+

288+instance FromJSON Word32 where

289+ parseJSON = parseIntegral

290+ {-# INLINE parseJSON #-}

291+

292+instance ToJSON Word64 where

293+ toJSON = Number . fromIntegral

294+ {-# INLINE toJSON #-}

295+

296+instance FromJSON Word64 where

297+ parseJSON = parseIntegral

298+ {-# INLINE parseJSON #-}

299+

300+instance ToJSON Text where

301+ toJSON = String

302+ {-# INLINE toJSON #-}

303+

304+instance FromJSON Text where

305+ parseJSON = withText "Text" pure

306+ {-# INLINE parseJSON #-}

307+

308+instance ToJSON LT.Text where

309+ toJSON = String . LT.toStrict

310+ {-# INLINE toJSON #-}

311+

312+instance FromJSON LT.Text where

313+ parseJSON = withText "Lazy Text" $ pure . LT.fromStrict

314+ {-# INLINE parseJSON #-}

315+

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

317+ toJSON = Array . V.fromList . map toJSON

318+ {-# INLINE toJSON #-}

319+

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

321+ parseJSON = withArray "[a]" $ mapM parseJSON . V.toList

322+ {-# INLINE parseJSON #-}

323+

324+instance (ToJSON a) => ToJSON (Vector a) where

325+ toJSON = Array . V.map toJSON

326+ {-# INLINE toJSON #-}

327+

328+instance (FromJSON a) => FromJSON (Vector a) where

329+ parseJSON = withArray "Vector a" $ V.mapM parseJSON

330+ {-# INLINE parseJSON #-}

331+

332+vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value

333+vectorToJSON = Array . V.map toJSON . V.convert

334+{-# INLINE vectorToJSON #-}

335+

336+vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)

337+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON

338+{-# INLINE vectorParseJSON #-}

339+

340+instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where

341+ toJSON = vectorToJSON

342+

343+instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where

344+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"

345+

346+instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where

347+ toJSON = vectorToJSON

348+

349+instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where

350+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"

351+

352+instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where

353+ toJSON = vectorToJSON

354+

355+instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where

356+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"

357+

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

359+ toJSON = toJSON . Set.toList

360+ {-# INLINE toJSON #-}

361+

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

363+ parseJSON = fmap Set.fromList . parseJSON

364+ {-# INLINE parseJSON #-}

365+

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

367+ toJSON = toJSON . HashSet.toList

368+ {-# INLINE toJSON #-}

369+

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

371+ parseJSON = fmap HashSet.fromList . parseJSON

372+ {-# INLINE parseJSON #-}

373+

374+instance ToJSON IntSet.IntSet where

375+ toJSON = toJSON . IntSet.toList

376+ {-# INLINE toJSON #-}

377+

378+instance FromJSON IntSet.IntSet where

379+ parseJSON = fmap IntSet.fromList . parseJSON

380+ {-# INLINE parseJSON #-}

381+

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

383+ toJSON = toJSON . IntMap.toList

384+ {-# INLINE toJSON #-}

385+

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

387+ parseJSON = fmap IntMap.fromList . parseJSON

388+ {-# INLINE parseJSON #-}

389+

390+instance (ToJSON v) => ToJSON (M.Map Text v) where

391+ toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty

392+ {-# INLINE toJSON #-}

393+

394+instance (FromJSON v) => FromJSON (M.Map Text v) where

395+ parseJSON = withObject "Map Text a" $

396+ fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON

397+

398+instance (ToJSON v) => ToJSON (M.Map LT.Text v) where

399+ toJSON = Object . mapHashKeyVal LT.toStrict toJSON

400+

401+instance (FromJSON v) => FromJSON (M.Map LT.Text v) where

402+ parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON

403+

404+instance (ToJSON v) => ToJSON (M.Map String v) where

405+ toJSON = Object . mapHashKeyVal pack toJSON

406+

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

408+ parseJSON = fmap (hashMapKey unpack) . parseJSON

409+

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

411+ toJSON = Object . H.map toJSON

412+ {-# INLINE toJSON #-}

413+

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

415+ parseJSON = withObject "HashMap Text a" $ traverse parseJSON

416+

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

418+ toJSON = Object . mapKeyVal LT.toStrict toJSON

419+

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

421+ parseJSON = fmap (mapKey LT.fromStrict) . parseJSON

422+

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

424+ toJSON = Object . mapKeyVal pack toJSON

425+

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

427+ parseJSON = fmap (mapKey unpack) . parseJSON

428+

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

430+ toJSON (Tree.Node root branches) = toJSON (root,branches)

431+

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

433+ parseJSON j = uncurry Tree.Node <$> parseJSON j

434+

435+instance ToJSON Value where

436+ toJSON a = a

437+ {-# INLINE toJSON #-}

438+

439+instance FromJSON Value where

440+ parseJSON a = pure a

441+ {-# INLINE parseJSON #-}

442+

443+instance ToJSON DotNetTime where

444+ toJSON (DotNetTime t) =

445+ String (pack (secs ++ msecs ++ ")/"))

446+ where secs = formatTime defaultTimeLocale "/Date(%s" t

447+ msecs = take 3 $ formatTime defaultTimeLocale "%q" t

448+ {-# INLINE toJSON #-}

449+

450+instance FromJSON DotNetTime where

451+ parseJSON = withText "DotNetTime" $ \t ->

452+ let (s,m) = T.splitAt (T.length t - 5) t

453+ t' = T.concat [s,".",m]

454+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

455+ Just d -> pure (DotNetTime d)

456+ _ -> fail "could not parse .NET time"

457+ {-# INLINE parseJSON #-}

458+

459+instance ToJSON ZonedTime where

460+ toJSON t = String $ pack $ formatTime defaultTimeLocale format t

461+ where

462+ format = "%FT%T" ++ milliseconds ++ tzFormat

463+ milliseconds = take 4 $ formatTime defaultTimeLocale "%Q" t

464+ tzFormat

465+ | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"

466+ | otherwise = "%z"

467+

468+instance FromJSON ZonedTime where

469+ parseJSON (String t) =

470+ tryFormats alternateFormats

471+ <|> fail "could not parse ECMA-262 ISO-8601 date"

472+ where

473+ tryFormat f =

474+ case parseTime defaultTimeLocale f (unpack t) of

475+ Just d -> pure d

476+ Nothing -> empty

477+ tryFormats = foldr1 (<|>) . map tryFormat

478+ alternateFormats =

479+ dateTimeFmt defaultTimeLocale :

480+ distributeList ["%Y", "%Y-%m", "%F"]

481+ ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]

482+

483+ distributeList xs ys =

484+ foldr (\x acc -> acc ++ distribute x ys) [] xs

485+ distribute x = map (mappend x)

486+

487+ parseJSON v = typeMismatch "ZonedTime" v

488+

489+instance ToJSON UTCTime where

490+ toJSON t = String (pack (take 23 str ++ "Z"))

491+ where str = formatTime defaultTimeLocale "%FT%T%Q" t

492+ {-# INLINE toJSON #-}

493+

494+instance FromJSON UTCTime where

495+ parseJSON = withText "UTCTime" $ \t ->

496+ case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of

497+ Just d -> pure d

498+ _ -> fail "could not parse ISO-8601 date"

499+ {-# INLINE parseJSON #-}

500+

501+instance (ToJSON a, ToJSON b) => ToJSON (a,b) where

502+ toJSON (a,b) = Array $ V.create $ do

503+ mv <- VM.unsafeNew 2

504+ VM.unsafeWrite mv 0 (toJSON a)

505+ VM.unsafeWrite mv 1 (toJSON b)

506+ return mv

507+ {-# INLINE toJSON #-}

508+

509+instance (FromJSON a, FromJSON b) => FromJSON (a,b) where

510+ parseJSON = withArray "(a,b)" $ \ab ->

511+ let n = V.length ab

512+ in if n == 2

513+ then (,) <$> parseJSON (V.unsafeIndex ab 0)

514+ <*> parseJSON (V.unsafeIndex ab 1)

515+ else fail $ "cannot unpack array of length " ++

516+ show n ++ " into a pair"

517+ {-# INLINE parseJSON #-}

518+

519+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where

520+ toJSON (a,b,c) = Array $ V.create $ do

521+ mv <- VM.unsafeNew 3

522+ VM.unsafeWrite mv 0 (toJSON a)

523+ VM.unsafeWrite mv 1 (toJSON b)

524+ VM.unsafeWrite mv 2 (toJSON c)

525+ return mv

526+ {-# INLINE toJSON #-}

527+

528+instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where

529+ parseJSON = withArray "(a,b,c)" $ \abc ->

530+ let n = V.length abc

531+ in if n == 3

532+ then (,,) <$> parseJSON (V.unsafeIndex abc 0)

533+ <*> parseJSON (V.unsafeIndex abc 1)

534+ <*> parseJSON (V.unsafeIndex abc 2)

535+ else fail $ "cannot unpack array of length " ++

536+ show n ++ " into a 3-tuple"

537+ {-# INLINE parseJSON #-}

538+

539+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where

540+ toJSON (a,b,c,d) = Array $ V.create $ do

541+ mv <- VM.unsafeNew 4

542+ VM.unsafeWrite mv 0 (toJSON a)

543+ VM.unsafeWrite mv 1 (toJSON b)

544+ VM.unsafeWrite mv 2 (toJSON c)

545+ VM.unsafeWrite mv 3 (toJSON d)

546+ return mv

547+ {-# INLINE toJSON #-}

548+

549+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where

550+ parseJSON = withArray "(a,b,c,d)" $ \abcd ->

551+ let n = V.length abcd

552+ in if n == 4

553+ then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)

554+ <*> parseJSON (V.unsafeIndex abcd 1)

555+ <*> parseJSON (V.unsafeIndex abcd 2)

556+ <*> parseJSON (V.unsafeIndex abcd 3)

557+ else fail $ "cannot unpack array of length " ++

558+ show n ++ " into a 4-tuple"

559+ {-# INLINE parseJSON #-}

560+

561+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a,b,c,d,e) where

562+ toJSON (a,b,c,d,e) = Array $ V.create $ do

563+ mv <- VM.unsafeNew 5

564+ VM.unsafeWrite mv 0 (toJSON a)

565+ VM.unsafeWrite mv 1 (toJSON b)

566+ VM.unsafeWrite mv 2 (toJSON c)

567+ VM.unsafeWrite mv 3 (toJSON d)

568+ VM.unsafeWrite mv 4 (toJSON e)

569+ return mv

570+ {-# INLINE toJSON #-}

571+

572+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a,b,c,d,e) where

573+ parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->

574+ let n = V.length abcde

575+ in if n == 5

576+ then (,,,,) <$> parseJSON (V.unsafeIndex abcde 0)

577+ <*> parseJSON (V.unsafeIndex abcde 1)

578+ <*> parseJSON (V.unsafeIndex abcde 2)

579+ <*> parseJSON (V.unsafeIndex abcde 3)

580+ <*> parseJSON (V.unsafeIndex abcde 4)

581+ else fail $ "cannot unpack array of length " ++

582+ show n ++ " into a 5-tuple"

583+ {-# INLINE parseJSON #-}

584+

585+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a,b,c,d,e,f) where

586+ toJSON (a,b,c,d,e,f) = Array $ V.create $ do

587+ mv <- VM.unsafeNew 6

588+ VM.unsafeWrite mv 0 (toJSON a)

589+ VM.unsafeWrite mv 1 (toJSON b)

590+ VM.unsafeWrite mv 2 (toJSON c)

591+ VM.unsafeWrite mv 3 (toJSON d)

592+ VM.unsafeWrite mv 4 (toJSON e)

593+ VM.unsafeWrite mv 5 (toJSON f)

594+ return mv

595+ {-# INLINE toJSON #-}

596+

597+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a,b,c,d,e,f) where

598+ parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->

599+ let n = V.length abcdef

600+ in if n == 6

601+ then (,,,,,) <$> parseJSON (V.unsafeIndex abcdef 0)

602+ <*> parseJSON (V.unsafeIndex abcdef 1)

603+ <*> parseJSON (V.unsafeIndex abcdef 2)

604+ <*> parseJSON (V.unsafeIndex abcdef 3)

605+ <*> parseJSON (V.unsafeIndex abcdef 4)

606+ <*> parseJSON (V.unsafeIndex abcdef 5)

607+ else fail $ "cannot unpack array of length " ++

608+ show n ++ " into a 6-tuple"

609+ {-# INLINE parseJSON #-}

610+

611+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a,b,c,d,e,f,g) where

612+ toJSON (a,b,c,d,e,f,g) = Array $ V.create $ do

613+ mv <- VM.unsafeNew 7

614+ VM.unsafeWrite mv 0 (toJSON a)

615+ VM.unsafeWrite mv 1 (toJSON b)

616+ VM.unsafeWrite mv 2 (toJSON c)

617+ VM.unsafeWrite mv 3 (toJSON d)

618+ VM.unsafeWrite mv 4 (toJSON e)

619+ VM.unsafeWrite mv 5 (toJSON f)

620+ VM.unsafeWrite mv 6 (toJSON g)

621+ return mv

622+ {-# INLINE toJSON #-}

623+

624+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where

625+ parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->

626+ let n = V.length abcdefg

627+ in if n == 7

628+ then (,,,,,,) <$> parseJSON (V.unsafeIndex abcdefg 0)

629+ <*> parseJSON (V.unsafeIndex abcdefg 1)

630+ <*> parseJSON (V.unsafeIndex abcdefg 2)

631+ <*> parseJSON (V.unsafeIndex abcdefg 3)

632+ <*> parseJSON (V.unsafeIndex abcdefg 4)

633+ <*> parseJSON (V.unsafeIndex abcdefg 5)

634+ <*> parseJSON (V.unsafeIndex abcdefg 6)

635+ else fail $ "cannot unpack array of length " ++

636+ show n ++ " into a 7-tuple"

637+ {-# INLINE parseJSON #-}

638+

639+instance ToJSON a => ToJSON (Dual a) where

640+ toJSON = toJSON . getDual

641+ {-# INLINE toJSON #-}

642+

643+instance FromJSON a => FromJSON (Dual a) where

644+ parseJSON = fmap Dual . parseJSON

645+ {-# INLINE parseJSON #-}

646+

647+instance ToJSON a => ToJSON (First a) where

648+ toJSON = toJSON . getFirst

649+ {-# INLINE toJSON #-}

650+

651+instance FromJSON a => FromJSON (First a) where

652+ parseJSON = fmap First . parseJSON

653+ {-# INLINE parseJSON #-}

654+

655+instance ToJSON a => ToJSON (Last a) where

656+ toJSON = toJSON . getLast

657+ {-# INLINE toJSON #-}

658+

659+instance FromJSON a => FromJSON (Last a) where

660+ parseJSON = fmap Last . parseJSON

661+ {-# INLINE parseJSON #-}

662+

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

664+-- and fails using @'typeMismatch' expected@ otherwise.

665+withObject :: String -> (Object -> Parser a) -> Value -> Parser a

666+withObject _ f (Object obj) = f obj

667+withObject expected _ v = typeMismatch expected v

668+{-# INLINE withObject #-}

669+

670+-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@

671+-- and fails using @'typeMismatch' expected@ otherwise.

672+withText :: String -> (Text -> Parser a) -> Value -> Parser a

673+withText _ f (String txt) = f txt

674+withText expected _ v = typeMismatch expected v

675+{-# INLINE withText #-}

676+

677+-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@

678+-- and fails using @'typeMismatch' expected@ otherwise.

679+withArray :: String -> (Array -> Parser a) -> Value -> Parser a

680+withArray _ f (Array arr) = f arr

681+withArray expected _ v = typeMismatch expected v

682+{-# INLINE withArray #-}

683+

684+-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@

685+-- and fails using @'typeMismatch' expected@ otherwise.

686+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a

687+withNumber _ f (Number num) = f num

688+withNumber expected _ v = typeMismatch expected v

689+{-# INLINE withNumber #-}

690+

691+-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@

692+-- and fails using @'typeMismatch' expected@ otherwise.

693+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a

694+withBool _ f (Bool arr) = f arr

695+withBool expected _ v = typeMismatch expected v

696+{-# INLINE withBool #-}

697+

698+-- | Construct a 'Pair' from a key and a value.

699+(.=) :: ToJSON a => Text -> a -> Pair

700+name .= value = (name, toJSON value)

701+{-# INLINE (.=) #-}

702+

703+-- | Convert a value from JSON, failing if the types do not match.

704+fromJSON :: (FromJSON a) => Value -> Result a

705+fromJSON = parse parseJSON

706+{-# INLINE fromJSON #-}

707+

708+-- | Retrieve the value associated with the given key of an 'Object'.

709+-- The result is 'empty' if the key is not present or the value cannot

710+-- be converted to the desired type.

711+--

712+-- This accessor is appropriate if the key and value /must/ be present

713+-- in an object for it to be valid. If the key and value are

714+-- optional, use '(.:?)' instead.

715+(.:) :: (FromJSON a) => Object -> Text -> Parser a

716+obj .: key = case H.lookup key obj of

717+ Nothing -> fail $ "key " ++ show key ++ " not present"

718+ Just v -> parseJSON v

719+{-# INLINE (.:) #-}

720+

721+-- | Retrieve the value associated with the given key of an 'Object'.

722+-- The result is 'Nothing' if the key is not present, or 'empty' if

723+-- the value cannot be converted to the desired type.

724+--

725+-- This accessor is most useful if the key and value can be absent

726+-- from an object without affecting its validity. If the key and

727+-- value are mandatory, use '(.:)' instead.

728+(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)

729+obj .:? key = case H.lookup key obj of

730+ Nothing -> pure Nothing

731+ Just v -> parseJSON v

732+{-# INLINE (.:?) #-}

733+

734+-- | Helper for use in combination with '.:?' to provide default

735+-- values for optional JSON object fields.

736+--

737+-- This combinator is most useful if the key and value can be absent

738+-- from an object without affecting its validity and we know a default

739+-- value to assign in that case. If the key and value are mandatory,

740+-- use '(.:)' instead.

741+--

742+-- Example usage:

743+--

744+-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"

745+-- v2 <- o '.:' \"mandatory_field\"

746+-- v3 <- o '.:?' \"opt_field2\"

747+-- @

748+(.!=) :: Parser (Maybe a) -> a -> Parser a

749+pmval .!= val = fromMaybe val <$> pmval

750+{-# INLINE (.!=) #-}

751+

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

753+typeMismatch :: String -- ^ The name of the type you are trying to parse.

754+ -> Value -- ^ The actual value encountered.

755+ -> Parser a

756+typeMismatch expected actual =

757+ fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++

758+ " instead"

759+ where

760+ name = case actual of

761+ Object _ -> "Object"

762+ Array _ -> "Array"

763+ String _ -> "String"

764+ Number _ -> "Number"

765+ Bool _ -> "Boolean"

766+ Null -> "Null"

Data/Aeson/Types/Internal.hs+17−1

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

1−{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}

1+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types #-}

3-- |

4-- Module: Data.Aeson.Types.Internal

@@ -35,6 +35,9 @@ module Data.Aeson.Types.Internal

35 , SumEncoding(..)

36 , defaultOptions

37 , defaultTaggedObject

38+

39+ -- * Other types

40+ , DotNetTime(..)

38 ) where

41 ) where

40import Control.Applicative

43import Control.Applicative

@@ -46,6 +49,8 @@ import Data.HashMap.Strict (HashMap)

46import Data.Monoid (Monoid(..))

49import Data.Monoid (Monoid(..))

47import Data.String (IsString(..))

50import Data.String (IsString(..))

48import Data.Text (Text, pack)

51import Data.Text (Text, pack)

52+import Data.Time (UTCTime)

53+import Data.Time.Format (FormatTime)

49import Data.Typeable (Typeable)

54import Data.Typeable (Typeable)

50import Data.Vector (Vector)

55import Data.Vector (Vector)

51import qualified Data.HashMap.Strict as H

56import qualified Data.HashMap.Strict as H

@@ -171,6 +176,17 @@ data Value = Object !Object

171 | Null

176 | Null

172 deriving (Eq, Show, Typeable)

177 deriving (Eq, Show, Typeable)

173

178

179+-- | A newtype wrapper for 'UTCTime' that uses the same non-standard

180+-- serialization format as Microsoft .NET, whose @System.DateTime@

181+-- type is by default serialized to JSON as in the following example:

182+--

183+-- > /Date(1302547608878)/

184+--

185+-- The number represents milliseconds since the Unix epoch.

186+newtype DotNetTime = DotNetTime {

187+ fromDotNetTime :: UTCTime

188+ } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)

189+

174instance NFData Value where

190instance NFData Value where

175 rnf (Object o) = rnf o

191 rnf (Object o) = rnf o

176 rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a

192 rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a

aeson.cabal+1

@@ -108,6 +108,7 @@ library

108 Data.Aeson.Functions

109 Data.Aeson.Parser.Internal

110 Data.Aeson.Types.Class

111+ Data.Aeson.Types.Instances

111 Data.Aeson.Types.Internal

112 Data.Aeson.Types.Internal

112

113

113 if impl(ghc >= 7.2.1)

114 if impl(ghc >= 7.2.1)