aeson 1.1.2.0 → 1.2.0.0
raw patch · 28 files changed
+826/−660 lines, 28 filesdep ~bytestringdep ~containersdep ~dlistPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bytestring, containers, dlist, unordered-containers
API changes (from Hackage documentation)
- Data.Aeson: class GToEncoding arity f
- Data.Aeson: class GToJSON arity f
- Data.Aeson: gToEncoding :: GToEncoding arity f => Options -> ToArgs Encoding arity a -> f a -> Encoding
- Data.Aeson: gToJSON :: GToJSON arity f => Options -> ToArgs Value arity a -> f a -> Value
- Data.Aeson.TH: Options :: (String -> String) -> (String -> String) -> Bool -> Bool -> SumEncoding -> Bool -> Options
- Data.Aeson.TH: [allNullaryToStringTag] :: Options -> Bool
- Data.Aeson.TH: [constructorTagModifier] :: Options -> String -> String
- Data.Aeson.TH: [fieldLabelModifier] :: Options -> String -> String
- Data.Aeson.TH: [omitNothingFields] :: Options -> Bool
- Data.Aeson.TH: [sumEncoding] :: Options -> SumEncoding
- Data.Aeson.TH: [unwrapUnaryRecords] :: Options -> Bool
- Data.Aeson.Types: Options :: (String -> String) -> (String -> String) -> Bool -> Bool -> SumEncoding -> Bool -> Options
- Data.Aeson.Types: [allNullaryToStringTag] :: Options -> Bool
- Data.Aeson.Types: [constructorTagModifier] :: Options -> String -> String
- Data.Aeson.Types: [fieldLabelModifier] :: Options -> String -> String
- Data.Aeson.Types: [omitNothingFields] :: Options -> Bool
- Data.Aeson.Types: [sumEncoding] :: Options -> SumEncoding
- Data.Aeson.Types: [unwrapUnaryRecords] :: Options -> Bool
- Data.Aeson.Types: class GToEncoding arity f
- Data.Aeson.Types: class GToJSON arity f
- Data.Aeson.Types: gToEncoding :: GToEncoding arity f => Options -> ToArgs Encoding arity a -> f a -> Encoding
- Data.Aeson.Types: gToJSON :: GToJSON arity f => Options -> ToArgs Value arity a -> f a -> Value
+ Data.Aeson: type GToEncoding = GToJSON Encoding
+ Data.Aeson: type GToJSON = GToJSON Value
+ Data.Aeson.Encoding: pairStr :: String -> Encoding -> Series
+ Data.Aeson.Encoding.Internal: pairStr :: String -> Encoding -> Series
+ Data.Aeson.Types: type GToEncoding = GToJSON Encoding
+ Data.Aeson.Types: type GToJSON = GToJSON Value
- Data.Aeson: genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f)) => Options -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
+ Data.Aeson: genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f)) => Options -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
- Data.Aeson: genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f)) => Options -> (a -> Value) -> ([a] -> Value) -> f a -> Value
+ Data.Aeson: genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f)) => Options -> (a -> Value) -> ([a] -> Value) -> f a -> Value
- Data.Aeson: genericToEncoding :: (Generic a, GToEncoding Zero (Rep a)) => Options -> a -> Encoding
+ Data.Aeson: genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a)) => Options -> a -> Encoding
- Data.Aeson: genericToJSON :: (Generic a, GToJSON Zero (Rep a)) => Options -> a -> Value
+ Data.Aeson: genericToJSON :: (Generic a, GToJSON Value Zero (Rep a)) => Options -> a -> Value
- Data.Aeson: liftToEncoding :: (ToJSON1 f, Generic1 f, GToEncoding One (Rep1 f)) => (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
+ Data.Aeson: liftToEncoding :: (ToJSON1 f, Generic1 f, GToJSON Encoding One (Rep1 f)) => (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
- Data.Aeson: liftToJSON :: (ToJSON1 f, Generic1 f, GToJSON One (Rep1 f)) => (a -> Value) -> ([a] -> Value) -> f a -> Value
+ Data.Aeson: liftToJSON :: (ToJSON1 f, Generic1 f, GToJSON Value One (Rep1 f)) => (a -> Value) -> ([a] -> Value) -> f a -> Value
- Data.Aeson: toJSON :: (ToJSON a, Generic a, GToJSON Zero (Rep a)) => a -> Value
+ Data.Aeson: toJSON :: (ToJSON a, Generic a, GToJSON Value Zero (Rep a)) => a -> Value
- Data.Aeson.Types: genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f)) => Options -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
+ Data.Aeson.Types: genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f)) => Options -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
- Data.Aeson.Types: genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f)) => Options -> (a -> Value) -> ([a] -> Value) -> f a -> Value
+ Data.Aeson.Types: genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f)) => Options -> (a -> Value) -> ([a] -> Value) -> f a -> Value
- Data.Aeson.Types: genericToEncoding :: (Generic a, GToEncoding Zero (Rep a)) => Options -> a -> Encoding
+ Data.Aeson.Types: genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a)) => Options -> a -> Encoding
- Data.Aeson.Types: genericToJSON :: (Generic a, GToJSON Zero (Rep a)) => Options -> a -> Value
+ Data.Aeson.Types: genericToJSON :: (Generic a, GToJSON Value Zero (Rep a)) => Options -> a -> Value
- Data.Aeson.Types: liftToEncoding :: (ToJSON1 f, Generic1 f, GToEncoding One (Rep1 f)) => (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
+ Data.Aeson.Types: liftToEncoding :: (ToJSON1 f, Generic1 f, GToJSON Encoding One (Rep1 f)) => (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
- Data.Aeson.Types: liftToJSON :: (ToJSON1 f, Generic1 f, GToJSON One (Rep1 f)) => (a -> Value) -> ([a] -> Value) -> f a -> Value
+ Data.Aeson.Types: liftToJSON :: (ToJSON1 f, Generic1 f, GToJSON Value One (Rep1 f)) => (a -> Value) -> ([a] -> Value) -> f a -> Value
- Data.Aeson.Types: toJSON :: (ToJSON a, Generic a, GToJSON Zero (Rep a)) => a -> Value
+ Data.Aeson.Types: toJSON :: (ToJSON a, Generic a, GToJSON Value Zero (Rep a)) => a -> Value
Files
- Data/Aeson.hs +2/−2
- Data/Aeson/Encoding.hs +1/−0
- Data/Aeson/Encoding/Builder.hs +0/−1
- Data/Aeson/Encoding/Internal.hs +6/−0
- Data/Aeson/Internal/Time.hs +1/−42
- Data/Aeson/Parser/Time.hs +17/−103
- Data/Aeson/TH.hs +5/−3
- Data/Aeson/Types.hs +2/−2
- Data/Aeson/Types/Class.hs +10/−3
- Data/Aeson/Types/FromJSON.hs +37/−13
- Data/Aeson/Types/Internal.hs +17/−2
- Data/Aeson/Types/ToJSON.hs +304/−434
- aeson.cabal +13/−11
- attoparsec-iso8601/Data/Attoparsec/Time.hs +149/−0
- attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs +61/−0
- benchmarks/AesonCompareAutoInstances.hs +80/−27
- benchmarks/Options.hs +1/−1
- benchmarks/aeson-benchmarks.cabal +4/−2
- changelog.md +12/−0
- pure/Data/Aeson/Parser/UnescapePure.hs +9/−4
- stack-lts6.yaml +3/−0
- stack-lts7.yaml +3/−0
- stack-lts8.yaml +3/−0
- stack-nightly.yaml +4/−3
- tests/Encoders.hs +28/−0
- tests/Options.hs +6/−0
- tests/Properties.hs +25/−5
- tests/UnitTests.hs +23/−2
Data/Aeson.hs view
@@ -76,8 +76,8 @@ -- ** Generic JSON classes and options , GFromJSON(..) , FromArgs(..)- , GToJSON(..)- , GToEncoding(..)+ , GToJSON+ , GToEncoding , ToArgs(..) , Zero , One
Data/Aeson/Encoding.hs view
@@ -14,6 +14,7 @@ , Series , pairs , pair+ , pairStr , pair' -- * Predicates , nullEncoding
Data/Aeson/Encoding/Builder.hs view
@@ -234,7 +234,6 @@ pico = 1000000000000 -- number of picoseconds in 1 second micro = 1000000 -- number of microseconds in 1 second milli = 1000 -- number of milliseconds in 1 second-{-# INLINE timeOfDay64 #-} timeZone :: TimeZone -> Builder timeZone (TimeZone off _ _)
Data/Aeson/Encoding/Internal.hs view
@@ -13,6 +13,7 @@ , Series (..) , pairs , pair+ , pairStr , pair' -- * Predicates , nullEncoding@@ -124,6 +125,11 @@ pair :: Text -> Encoding -> Series pair name val = pair' (text name) val+{-# INLINE pair #-}++pairStr :: String -> Encoding -> Series+pairStr name val = pair' (string name) val+{-# INLINE pairStr #-} pair' :: Encoding' Text -> Encoding -> Series pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val
Data/Aeson/Internal/Time.hs view
@@ -17,45 +17,4 @@ , toTimeOfDay64 ) where -import Prelude ()-import Prelude.Compat--import Data.Int (Int64)-import Data.Time-import Unsafe.Coerce (unsafeCoerce)--#if MIN_VERSION_base(4,7,0)--import Data.Fixed (Pico, Fixed(MkFixed))--toPico :: Integer -> Pico-toPico = MkFixed--fromPico :: Pico -> Integer-fromPico (MkFixed i) = i--#else--import Data.Fixed (Pico)--toPico :: Integer -> Pico-toPico = unsafeCoerce--fromPico :: Pico -> Integer-fromPico = unsafeCoerce--#endif---- | Like TimeOfDay, but using a fixed-width integer for seconds.-data TimeOfDay64 = TOD {-# UNPACK #-} !Int- {-# UNPACK #-} !Int- {-# UNPACK #-} !Int64--diffTimeOfDay64 :: DiffTime -> TimeOfDay64-diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s- where (h,mp) = fromIntegral pico `quotRem` 3600000000000000- (m,s) = mp `quotRem` 60000000000000- pico = unsafeCoerce t :: Integer--toTimeOfDay64 :: TimeOfDay -> TimeOfDay64-toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))+import Data.Attoparsec.Time.Internal
Data/Aeson/Parser/Time.hs view
@@ -1,16 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module: Data.Aeson.Parser.Time--- Copyright: (c) 2015-2016 Bryan O'Sullivan--- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>--- Stability: experimental--- Portability: portable------ Parsers for parsing dates and times.- module Data.Aeson.Parser.Time ( run@@ -25,120 +12,49 @@ import Prelude () import Prelude.Compat -import Control.Applicative ((<|>))-import Control.Monad (void, when)-import Data.Aeson.Internal.Time (toPico)-import Data.Attoparsec.Text as A-import Data.Bits ((.&.))-import Data.Char (isDigit, ord)-import Data.Fixed (Pico)-import Data.Int (Int64)-import Data.Maybe (fromMaybe)+import Data.Attoparsec.Text (Parser) import Data.Text (Text)-import Data.Time.Calendar (Day, fromGregorianValid)+import Data.Time.Calendar (Day) import Data.Time.Clock (UTCTime(..)) import qualified Data.Aeson.Types.Internal as Aeson-import qualified Data.Text as T+import qualified Data.Attoparsec.Text as A+import qualified Data.Attoparsec.Time as T import qualified Data.Time.LocalTime as Local -- | Run an attoparsec parser as an aeson parser. run :: Parser a -> Text -> Aeson.Parser a-run p t = case A.parseOnly (p <* endOfInput) t of+run p t = case A.parseOnly (p <* A.endOfInput) t of Left err -> fail $ "could not parse date: " ++ err Right r -> return r -- | Parse a date of the form @[+,-]YYYY-MM-DD@. day :: Parser Day-day = do- absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id- y <- decimal <* char '-'- m <- twoDigits <* char '-'- d <- twoDigits- maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)---- | Parse a two-digit integer (e.g. day of month, hour).-twoDigits :: Parser Int-twoDigits = do- a <- digit- b <- digit- let c2d c = ord c .&. 15- return $! c2d a * 10 + c2d b+day = T.day+{-# INLINE day #-} -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. timeOfDay :: Parser Local.TimeOfDay-timeOfDay = do- h <- twoDigits- m <- char ':' *> twoDigits- s <- option 0 (char ':' *> seconds)- if h < 24 && m < 60 && s < 61- then return (Local.TimeOfDay h m s)- else fail "invalid time"--data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64---- | Parse a count of seconds, with the integer part being two digits--- long.-seconds :: Parser Pico-seconds = do- real <- twoDigits- mc <- peekChar- case mc of- Just '.' -> do- t <- anyChar *> takeWhile1 isDigit- return $! parsePicos real t- _ -> return $! fromIntegral real- where- parsePicos a0 t = toPico (fromIntegral (t' * 10^n))- where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t- step ma@(T m a) c- | m <= 0 = ma- | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)+timeOfDay = T.timeOfDay+{-# INLINE timeOfDay #-} -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) timeZone :: Parser (Maybe Local.TimeZone)-timeZone = do- let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)- maybeSkip ' '- ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'- if ch == 'Z'- then return Nothing- else do- h <- twoDigits- mm <- peekChar- m <- case mm of- Just ':' -> anyChar *> twoDigits- Just d | isDigit d -> twoDigits- _ -> return 0- let off | ch == '-' = negate off0- | otherwise = off0- off0 = h * 60 + m- case undefined of- _ | off == 0 ->- return Nothing- | off < -720 || off > 840 || m > 59 ->- fail "invalid time zone offset"- | otherwise ->- let !tz = Local.minutesToTimeZone off- in return (Just tz)+timeZone = T.timeZone+{-# INLINE timeZone #-} -- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@. -- The space may be replaced with a @T@. The number of seconds is optional -- and may be followed by a fractional component. localTime :: Parser Local.LocalTime-localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay- where daySep = satisfy (\c -> c == 'T' || c == ' ')+localTime = T.localTime+{-# INLINE localTime #-} -- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time. utcTime :: Parser UTCTime-utcTime = do- lt@(Local.LocalTime d t) <- localTime- mtz <- timeZone- case mtz of- Nothing -> let !tt = Local.timeOfDayToTime t- in return (UTCTime d tt)- Just tz -> return $! Local.localTimeToUTC tz lt+utcTime = T.utcTime+{-# INLINE utcTime #-} -- | Parse a date with time zone info. Acceptable formats: --@@ -152,7 +68,5 @@ -- two digits are hours, the @:@ is optional and the second two digits -- (also optional) are minutes. zonedTime :: Parser Local.ZonedTime-zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)--utc :: Local.TimeZone-utc = Local.TimeZone 0 False ""+zonedTime = T.zonedTime+{-# INLINE zonedTime #-}
Data/Aeson/TH.hs view
@@ -341,7 +341,7 @@ matches tjs = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten.- [con] -> [argsToValue jc tjs opts False con]+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con] _ | allNullaryToStringTag opts && all isNullary cons -> [ match (conP conName []) (normalB $ conStr opts conName) [] | con <- cons@@ -384,7 +384,7 @@ matches tes = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten.- [con] -> [argsToEncoding jc tes opts False con]+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con] -- Encode just the name of the constructor of a sum type iff all the -- constructors are nullary. _ | allNullaryToStringTag opts && all isNullary cons ->@@ -792,7 +792,9 @@ where lamExpr value pjs = case cons of- [con] -> parseArgs jc pjs tName opts con (Right value)+ [con]+ | not (tagSingleConstructors opts)+ -> parseArgs jc pjs tName opts con (Right value) _ | sumEncoding opts == UntaggedValue -> parseUntaggedValue pjs cons value | otherwise
Data/Aeson/Types.hs view
@@ -63,8 +63,8 @@ -- ** Generic JSON classes , GFromJSON(..) , FromArgs(..)- , GToJSON(..)- , GToEncoding(..)+ , GToJSON+ , GToEncoding , ToArgs(..) , Zero , One
Data/Aeson/Types/Class.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -36,8 +37,8 @@ -- * Generic JSON classes , GFromJSON(..) , FromArgs(..)- , GToJSON(..)- , GToEncoding(..)+ , GToJSON+ , GToEncoding , ToArgs(..) , Zero , One@@ -94,4 +95,10 @@ import Data.Aeson.Types.FromJSON import Data.Aeson.Types.Generic (One, Zero)-import Data.Aeson.Types.ToJSON+import Data.Aeson.Types.ToJSON hiding (GToJSON)+import qualified Data.Aeson.Types.ToJSON as ToJSON+import Data.Aeson.Types.Internal (Value)+import Data.Aeson.Encoding (Encoding)++type GToJSON = ToJSON.GToJSON Value+type GToEncoding = ToJSON.GToJSON Encoding
Data/Aeson/Types/FromJSON.hs view
@@ -791,6 +791,19 @@ | isEmptyArray v = pure U1 | otherwise = typeMismatch "unit constructor (U1)" v +instance ( ConsFromJSON arity a+ , AllNullary (C1 c a) allNullary+ , ParseSum arity (C1 c a) allNullary+ ) => GFromJSON arity (D1 d (C1 c a)) where+ -- The option 'tagSingleConstructors' determines whether to wrap+ -- a single-constructor type.+ gParseJSON opts fargs+ | tagSingleConstructors opts+ = fmap M1+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))+ . parseSum opts fargs+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs+ instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where -- Constructors need to be decoded differently depending on whether they're -- a record or not. This distinction is made by consParseJSON:@@ -837,19 +850,19 @@ parseSum :: Options -> FromArgs arity a -> Value -> Tagged allNullary (Parser (f a)) -instance ( SumFromString (a :+: b)- , FromPair arity (a :+: b)- , FromTaggedObject arity (a :+: b)- , FromUntaggedValue arity (a :+: b)- ) => ParseSum arity (a :+: b) True where+instance ( SumFromString f+ , FromPair arity f+ , FromTaggedObject arity f+ , FromUntaggedValue arity f+ ) => ParseSum arity f True where parseSum opts fargs | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts | otherwise = Tagged . parseNonAllNullarySum opts fargs -instance ( FromPair arity (a :+: b)- , FromTaggedObject arity (a :+: b)- , FromUntaggedValue arity (a :+: b)- ) => ParseSum arity (a :+: b) False where+instance ( FromPair arity f+ , FromTaggedObject arity f+ , FromUntaggedValue arity f+ ) => ParseSum arity f False where parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs --------------------------------------------------------------------------------@@ -875,11 +888,11 @@ -------------------------------------------------------------------------------- -parseNonAllNullarySum :: ( FromPair arity (a :+: b)- , FromTaggedObject arity (a :+: b)- , FromUntaggedValue arity (a :+: b)+parseNonAllNullarySum :: ( FromPair arity f+ , FromTaggedObject arity f+ , FromUntaggedValue arity f ) => Options -> FromArgs arity c- -> Value -> Parser ((a :+: b) c)+ -> Value -> Parser (f c) parseNonAllNullarySum opts fargs = case sumEncoding opts of TaggedObject{..} ->@@ -1658,6 +1671,17 @@ fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime) +-- | Supported string formats:+--+-- @YYYY-MM-DD HH:MM Z@+-- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes. instance FromJSON ZonedTime where parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
Data/Aeson/Types/Internal.hs view
@@ -49,7 +49,16 @@ , object -- * Generic and TH encoding configuration- , Options(..)+ , Options(+ fieldLabelModifier+ , constructorTagModifier+ , allNullaryToStringTag+ , omitNothingFields+ , sumEncoding+ , unwrapUnaryRecords+ , tagSingleConstructors+ )+ , SumEncoding(..) , defaultOptions , defaultTaggedObject@@ -524,10 +533,13 @@ , unwrapUnaryRecords :: Bool -- ^ Hide the field name when a record constructor has only one -- field, like a newtype.+ , tagSingleConstructors :: Bool+ -- ^ Encode types with a single constructor as sums,+ -- so that `allNullaryToStringTag` and `sumEncoding` apply. } instance Show Options where- show (Options f c a o s u) =+ show (Options f c a o s u t) = "Options {" ++ intercalate ", " [ "fieldLabelModifier =~ " ++ show (f "exampleField")@@ -536,6 +548,7 @@ , "omitNothingFields = " ++ show o , "sumEncoding = " ++ show s , "unwrapUnaryRecords = " ++ show u+ , "tagSingleConstructors = " ++ show t ] ++ "}" @@ -589,6 +602,7 @@ -- , 'omitNothingFields' = False -- , 'sumEncoding' = 'defaultTaggedObject' -- , 'unwrapUnaryRecords' = False+-- , 'tagSingleConstructors' = False -- } -- @ defaultOptions :: Options@@ -599,6 +613,7 @@ , omitNothingFields = False , sumEncoding = defaultTaggedObject , unwrapUnaryRecords = False+ , tagSingleConstructors = False } -- | Default 'TaggedObject' 'SumEncoding' options:
Data/Aeson/Types/ToJSON.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}@@ -36,7 +37,6 @@ , toEncoding2 -- * Generic JSON classes , GToJSON(..)- , GToEncoding(..) , ToArgs(..) , genericToJSON , genericToEncoding@@ -61,7 +61,7 @@ import Control.Applicative (Const(..)) import Control.Monad.ST (ST) import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)-import Data.Aeson.Encoding.Internal ((>*<), (><))+import Data.Aeson.Encoding.Internal ((>*<)) import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal) import Data.Aeson.Types.Generic (AllNullary, False, IsRecord(..), One, ProductSize, Tagged2(..), True, Zero, productSize) import Data.Aeson.Types.Internal@@ -93,7 +93,7 @@ import GHC.Generics import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E-import qualified Data.Aeson.Encoding.Internal as E (InArray, colon, comma, econcat, empty, retagEncoding, wrapObject)+import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList@@ -149,19 +149,16 @@ -- | Class of generic representation types that can be converted to -- JSON.-class GToJSON arity f where+class GToJSON enc arity f where -- | This method (applied to 'defaultOptions') is used as the- -- default generic implementation of 'toJSON' (if the @arity@ is 'Zero')- -- or 'liftToJSON' (if the @arity@ is 'One').- gToJSON :: Options -> ToArgs Value arity a -> f a -> Value---- | Class of generic representation types that can be converted to--- a JSON 'Encoding'.-class GToEncoding arity f where- -- | This method (applied to 'defaultOptions') can be used as the- -- default generic implementation of 'toEncoding' (if the @arity@ is 'Zero')- -- or 'liftToEncoding' (if the @arity@ is 'One').- gToEncoding :: Options -> ToArgs Encoding arity a -> f a -> Encoding+ -- default generic implementation of 'toJSON'+ -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)+ -- and 'liftToJSON' (if the @arity@ is 'One').+ --+ -- It also provides a generic implementation of 'toEncoding'+ -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)+ -- and 'liftToEncoding' (if the @arity@ is 'One').+ gToJSON :: Options -> ToArgs enc arity a -> f a -> enc -- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two -- function arguments that encode occurrences of the type parameter (for@@ -173,14 +170,14 @@ -- | A configurable generic JSON creator. This function applied to -- 'defaultOptions' is used as the default for 'toJSON' when the type -- is an instance of 'Generic'.-genericToJSON :: (Generic a, GToJSON Zero (Rep a))+genericToJSON :: (Generic a, GToJSON Value Zero (Rep a)) => Options -> a -> Value genericToJSON opts = gToJSON opts NoToArgs . from -- | A configurable generic JSON creator. This function applied to -- 'defaultOptions' is used as the default for 'liftToJSON' when the type -- is an instance of 'Generic1'.-genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f))+genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f)) => Options -> (a -> Value) -> ([a] -> Value) -> f a -> Value genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1@@ -188,17 +185,17 @@ -- | A configurable generic JSON encoder. This function applied to -- 'defaultOptions' is used as the default for 'toEncoding' when the type -- is an instance of 'Generic'.-genericToEncoding :: (Generic a, GToEncoding Zero (Rep a))+genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a)) => Options -> a -> Encoding-genericToEncoding opts = gToEncoding opts NoToArgs . from+genericToEncoding opts = gToJSON opts NoToArgs . from -- | A configurable generic JSON encoder. This function applied to -- 'defaultOptions' is used as the default for 'liftToEncoding' when the type -- is an instance of 'Generic1'.-genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))+genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f)) => Options -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding-genericLiftToEncoding opts te tel = gToEncoding opts (To1Args te tel) . from1+genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1 ------------------------------------------------------------------------------- -- Class@@ -284,7 +281,7 @@ -- | Convert a Haskell value to a JSON-friendly intermediate type. toJSON :: a -> Value - default toJSON :: (Generic a, GToJSON Zero (Rep a)) => a -> Value+ default toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value toJSON = genericToJSON defaultOptions -- | Encode a Haskell value as JSON.@@ -544,7 +541,7 @@ class ToJSON1 f where liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value - default liftToJSON :: (Generic1 f, GToJSON One (Rep1 f))+ default liftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f)) => (a -> Value) -> ([a] -> Value) -> f a -> Value liftToJSON = genericLiftToJSON defaultOptions @@ -553,7 +550,7 @@ liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding - default liftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))+ default liftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f)) => (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding liftToEncoding = genericLiftToEncoding defaultOptions@@ -653,39 +650,66 @@ -- Generic toJSON / toEncoding ------------------------------------------------------------------------------- ------------------------------------------------------------------------------------ Generic toJSON--instance OVERLAPPABLE_ (GToJSON arity a) => GToJSON arity (M1 i c a) where+instance OVERLAPPABLE_ (GToJSON enc arity a) => GToJSON enc arity (M1 i c a) where -- Meta-information, which is not handled elsewhere, is ignored: gToJSON opts targs = gToJSON opts targs . unM1 -instance (ToJSON a) => GToJSON arity (K1 i a) where- -- Constant values are encoded using their ToJSON instance:- gToJSON _opts _ = toJSON . unK1--instance GToJSON One Par1 where+instance GToJSON enc One Par1 where -- Direct occurrences of the last type parameter are encoded with the -- function passed in as an argument: gToJSON _opts (To1Args tj _) = tj . unPar1 -instance (ToJSON1 f) => GToJSON One (Rec1 f) where+instance ( ConsToJSON enc arity a+ , AllNullary (C1 c a) allNullary+ , SumToJSON enc arity (C1 c a) allNullary+ ) => GToJSON enc arity (D1 d (C1 c a)) where+ -- The option 'tagSingleConstructors' determines whether to wrap+ -- a single-constructor type.+ gToJSON opts targs+ | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)+ . sumToJSON opts targs+ . unM1+ | otherwise = consToJSON opts targs . unM1 . unM1++instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where+ -- Constructors need to be encoded differently depending on whether they're+ -- a record or not. This distinction is made by 'consToJSON':+ gToJSON opts targs = consToJSON opts targs . unM1++instance ( AllNullary (a :+: b) allNullary+ , SumToJSON enc arity (a :+: b) allNullary+ ) => GToJSON enc arity (a :+: b)+ where+ -- If all constructors of a sum datatype are nullary and the+ -- 'allNullaryToStringTag' option is set they are encoded to+ -- strings. This distinction is made by 'sumToJSON':+ gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)+ . sumToJSON opts targs++--------------------------------------------------------------------------------+-- Generic toJSON++-- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is+-- possible but makes error messages a bit harder to understand for missing+-- instances.++instance ToJSON a => GToJSON Value arity (K1 i a) where+ -- Constant values are encoded using their ToJSON instance:+ gToJSON _opts _ = toJSON . unK1++instance ToJSON1 f => GToJSON Value One (Rec1 f) where -- Recursive occurrences of the last type parameter are encoded using their -- ToJSON1 instance: gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1 -instance GToJSON arity U1 where+instance GToJSON Value arity U1 where -- Empty constructors are encoded to an empty array: gToJSON _opts _ _ = emptyArray -instance (ConsToJSON arity a) => GToJSON arity (C1 c a) where- -- Constructors need to be encoded differently depending on whether they're- -- a record or not. This distinction is made by 'consToJSON':- gToJSON opts targs = consToJSON opts targs . unM1- instance ( WriteProduct arity a, WriteProduct arity b , ProductSize a, ProductSize b- ) => GToJSON arity (a :*: b) where+ ) => GToJSON Value arity (a :*: b)+ where -- Products are encoded to an array. Here we allocate a mutable vector of -- the same size as the product and write the product's elements to it using -- 'writeProduct':@@ -698,16 +722,10 @@ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int) productSize -instance ( AllNullary (a :+: b) allNullary- , SumToJSON arity (a :+: b) allNullary- ) => GToJSON arity (a :+: b) where- -- If all constructors of a sum datatype are nullary and the- -- 'allNullaryToStringTag' option is set they are encoded to- -- strings. This distinction is made by 'sumToJSON':- gToJSON opts targs = (unTagged :: Tagged allNullary Value -> Value)- . sumToJSON opts targs--instance (ToJSON1 f, GToJSON One g) => GToJSON One (f :.: g) where+instance ( ToJSON1 f+ , GToJSON Value One g+ ) => GToJSON Value One (f :.: g)+ where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is encoded by using the outermost type's ToJSON1 -- instance to generically encode the innermost type:@@ -718,216 +736,153 @@ -------------------------------------------------------------------------------- -- Generic toEncoding -instance OVERLAPPABLE_ (GToEncoding arity a) => GToEncoding arity (M1 i c a) where- -- Meta-information, which is not handled elsewhere, is ignored:- gToEncoding opts targs = gToEncoding opts targs . unM1--instance (ToJSON a) => GToEncoding arity (K1 i a) where+instance ToJSON a => GToJSON Encoding arity (K1 i a) where -- Constant values are encoded using their ToJSON instance:- gToEncoding _opts _ = toEncoding . unK1--instance GToEncoding One Par1 where- -- Direct occurrences of the last type parameter are encoded with the- -- function passed in as an argument:- gToEncoding _opts (To1Args te _) = te . unPar1+ gToJSON _opts _ = toEncoding . unK1 -instance (ToJSON1 f) => GToEncoding One (Rec1 f) where+instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where -- Recursive occurrences of the last type parameter are encoded using their -- ToEncoding1 instance:- gToEncoding _opts (To1Args te tel) = liftToEncoding te tel . unRec1+ gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1 -instance GToEncoding arity U1 where+instance GToJSON Encoding arity U1 where -- Empty constructors are encoded to an empty array:- gToEncoding _opts _ _ = E.emptyArray_--instance (ConsToEncoding arity a) => GToEncoding arity (C1 c a) where- -- Constructors need to be encoded differently depending on whether they're- -- a record or not. This distinction is made by 'consToEncoding':- gToEncoding opts targs = consToEncoding opts targs . unM1+ gToJSON _opts _ _ = E.emptyArray_ instance ( EncodeProduct arity a , EncodeProduct arity b- ) => GToEncoding arity (a :*: b) where+ ) => GToJSON Encoding arity (a :*: b)+ where -- Products are encoded to an array. Here we allocate a mutable vector of -- the same size as the product and write the product's elements to it using -- 'encodeProduct':- gToEncoding opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]--instance ( AllNullary (a :+: b) allNullary- , SumToEncoding arity (a :+: b) allNullary- ) => GToEncoding arity (a :+: b) where- -- If all constructors of a sum datatype are nullary and the- -- 'allNullaryToStringTag' option is set they are encoded to- -- strings. This distinction is made by 'sumToEncoding':- gToEncoding opts targs- = (unTagged :: Tagged allNullary Encoding -> Encoding)- . sumToEncoding opts targs+ gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p] -instance (ToJSON1 f, GToEncoding One g) => GToEncoding One (f :.: g) where+instance ( ToJSON1 f+ , GToJSON Encoding One g+ ) => GToJSON Encoding One (f :.: g)+ where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is encoded by using the outermost type's ToJSON1 -- instance to generically encode the innermost type:- gToEncoding opts targs =- let gte = gToEncoding opts targs in+ gToJSON opts targs =+ let gte = gToJSON opts targs in liftToEncoding gte (listEncoding gte) . unComp1 -------------------------------------------------------------------------------- -class SumToJSON arity f allNullary where- sumToJSON :: Options -> ToArgs Value arity a- -> f a -> Tagged allNullary Value+class SumToJSON enc arity f allNullary where+ sumToJSON :: Options -> ToArgs enc arity a+ -> f a -> Tagged allNullary enc -instance ( GetConName f- , TaggedObjectPairs arity f- , ObjectWithSingleFieldObj arity f- , TwoElemArrayObj arity f- , UntaggedValueObj arity f- ) => SumToJSON arity f True where+instance ( GetConName f+ , FromString enc+ , TaggedObject enc arity f+ , SumToJSON' ObjectWithSingleField enc arity f+ , SumToJSON' TwoElemArray enc arity f+ , SumToJSON' UntaggedValue enc arity f+ ) => SumToJSON enc arity f True+ where sumToJSON opts targs- | allNullaryToStringTag opts = Tagged . String . pack+ | allNullaryToStringTag opts = Tagged . fromString . constructorTagModifier opts . getConName | otherwise = Tagged . nonAllNullarySumToJSON opts targs -instance ( TwoElemArrayObj arity f- , TaggedObjectPairs arity f- , ObjectWithSingleFieldObj arity f- , UntaggedValueObj arity f- ) => SumToJSON arity f False where+instance ( TaggedObject enc arity f+ , SumToJSON' ObjectWithSingleField enc arity f+ , SumToJSON' TwoElemArray enc arity f+ , SumToJSON' UntaggedValue enc arity f+ ) => SumToJSON enc arity f False+ where sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs -nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f- , TaggedObjectPairs arity f- , ObjectWithSingleFieldObj arity f- , UntaggedValueObj arity f- ) => Options -> ToArgs Value arity a- -> f a -> Value+nonAllNullarySumToJSON :: ( TaggedObject enc arity f+ , SumToJSON' ObjectWithSingleField enc arity f+ , SumToJSON' TwoElemArray enc arity f+ , SumToJSON' UntaggedValue enc arity f+ ) => Options -> ToArgs enc arity a+ -> f a -> enc nonAllNullarySumToJSON opts targs = case sumEncoding opts of- TaggedObject{..} ->- object . taggedObjectPairs opts targs tagFieldName contentsFieldName- ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs- TwoElemArray -> Array . twoElemArrayObj opts targs- UntaggedValue -> untaggedValueObj opts targs -----------------------------------------------------------------------------------class SumToEncoding arity f allNullary where- sumToEncoding :: Options -> ToArgs Encoding arity a- -> f a -> Tagged allNullary Encoding--instance ( GetConName f- , TaggedObjectEnc arity f- , ObjectWithSingleFieldEnc arity f- , TwoElemArrayEnc arity f- , UntaggedValueEnc arity f- ) => SumToEncoding arity f True where- sumToEncoding opts targs- | allNullaryToStringTag opts = Tagged . toEncoding .- constructorTagModifier opts . getConName- | otherwise = Tagged . nonAllNullarySumToEncoding opts targs--instance ( TwoElemArrayEnc arity f- , TaggedObjectEnc arity f- , ObjectWithSingleFieldEnc arity f- , UntaggedValueEnc arity f- ) => SumToEncoding arity f False where- sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs--nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f- , TaggedObjectEnc arity f- , ObjectWithSingleFieldEnc arity f- , UntaggedValueEnc arity f- ) => Options -> ToArgs Encoding arity a- -> f a -> Encoding-nonAllNullarySumToEncoding opts targs =- case sumEncoding opts of TaggedObject{..} ->- taggedObjectEnc opts targs tagFieldName contentsFieldName- ObjectWithSingleField -> objectWithSingleFieldEnc opts targs- TwoElemArray -> twoElemArrayEnc opts targs- UntaggedValue -> untaggedValueEnc opts targs----------------------------------------------------------------------------------+ taggedObject opts targs tagFieldName contentsFieldName -class TaggedObjectPairs arity f where- taggedObjectPairs :: Options -> ToArgs Value arity a- -> String -> String- -> f a -> [Pair]+ ObjectWithSingleField ->+ (unTagged :: Tagged ObjectWithSingleField enc -> enc)+ . sumToJSON' opts targs -instance ( TaggedObjectPairs arity a- , TaggedObjectPairs arity b- ) => TaggedObjectPairs arity (a :+: b) where- taggedObjectPairs opts targs tagFieldName contentsFieldName (L1 x) =- taggedObjectPairs opts targs tagFieldName contentsFieldName x- taggedObjectPairs opts targs tagFieldName contentsFieldName (R1 x) =- taggedObjectPairs opts targs tagFieldName contentsFieldName x+ TwoElemArray ->+ (unTagged :: Tagged TwoElemArray enc -> enc)+ . sumToJSON' opts targs -instance ( IsRecord a isRecord- , TaggedObjectPairs' arity a isRecord- , Constructor c- ) => TaggedObjectPairs arity (C1 c a) where- taggedObjectPairs opts targs tagFieldName contentsFieldName =- (pack tagFieldName .= constructorTagModifier opts- (conName (undefined :: t c a p)) :) .- (unTagged :: Tagged isRecord [Pair] -> [Pair]) .- taggedObjectPairs' opts targs contentsFieldName . unM1+ UntaggedValue ->+ (unTagged :: Tagged UntaggedValue enc -> enc)+ . sumToJSON' opts targs -class TaggedObjectPairs' arity f isRecord where- taggedObjectPairs' :: Options -> ToArgs Value arity a- -> String -> f a -> Tagged isRecord [Pair]+-------------------------------------------------------------------------------- -instance OVERLAPPING_ TaggedObjectPairs' arity U1 False where- taggedObjectPairs' _ _ _ _ = Tagged []+class FromString enc where+ fromString :: String -> enc -instance (RecordToPairs arity f) => TaggedObjectPairs' arity f True where- taggedObjectPairs' opts targs _ =- Tagged . toList . recordToPairs opts targs+instance FromString Encoding where+ fromString = toEncoding -instance (GToJSON arity f) => TaggedObjectPairs' arity f False where- taggedObjectPairs' opts targs contentsFieldName =- Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts targs+instance FromString Value where+ fromString = String . pack -------------------------------------------------------------------------------- -class TaggedObjectEnc arity f where- taggedObjectEnc :: Options -> ToArgs Encoding arity a- -> String -> String- -> f a -> Encoding+class TaggedObject enc arity f where+ taggedObject :: Options -> ToArgs enc arity a+ -> String -> String+ -> f a -> enc -instance ( TaggedObjectEnc arity a- , TaggedObjectEnc arity b- ) => TaggedObjectEnc arity (a :+: b) where- taggedObjectEnc opts targs tagFieldName contentsFieldName (L1 x) =- taggedObjectEnc opts targs tagFieldName contentsFieldName x- taggedObjectEnc opts targs tagFieldName contentsFieldName (R1 x) =- taggedObjectEnc opts targs tagFieldName contentsFieldName x+instance ( TaggedObject enc arity a+ , TaggedObject enc arity b+ ) => TaggedObject enc arity (a :+: b)+ where+ taggedObject opts targs tagFieldName contentsFieldName (L1 x) =+ taggedObject opts targs tagFieldName contentsFieldName x+ taggedObject opts targs tagFieldName contentsFieldName (R1 x) =+ taggedObject opts targs tagFieldName contentsFieldName x -instance ( IsRecord a isRecord- , TaggedObjectEnc' arity a isRecord+instance ( IsRecord a isRecord+ , TaggedObject' enc pairs arity a isRecord+ , FromPairs enc pairs+ , FromString enc+ , GKeyValue enc pairs , Constructor c- ) => TaggedObjectEnc arity (C1 c a) where- taggedObjectEnc opts targs tagFieldName contentsFieldName v = E.pairs (E.pair key val)+ ) => TaggedObject enc arity (C1 c a)+ where+ taggedObject opts targs tagFieldName contentsFieldName =+ fromPairs . (tag <>) . contents where- key :: Text- key = pack tagFieldName- val = toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))- >< ((unTagged :: Tagged isRecord Encoding -> Encoding) . taggedObjectEnc' opts targs contentsFieldName . unM1 $ v)+ tag = tagFieldName `gPair`+ (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))+ :: enc)+ contents =+ (unTagged :: Tagged isRecord pairs -> pairs) .+ taggedObject' opts targs contentsFieldName . unM1 -class TaggedObjectEnc' arity f isRecord where- taggedObjectEnc' :: Options -> ToArgs Encoding arity a- -> String -> f a -> Tagged isRecord Encoding+class TaggedObject' enc pairs arity f isRecord where+ taggedObject' :: Options -> ToArgs enc arity a+ -> String -> f a -> Tagged isRecord pairs -instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where- taggedObjectEnc' _ _ _ _ = Tagged E.empty+instance ( GToJSON enc arity f+ , GKeyValue enc pairs+ ) => TaggedObject' enc pairs arity f False+ where+ taggedObject' opts targs contentsFieldName =+ Tagged . (contentsFieldName `gPair`) . gToJSON opts targs -instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where- taggedObjectEnc' opts targs _ = Tagged . (E.comma ><) . fst- . recordToEncoding opts targs+instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where+ taggedObject' _ _ _ _ = Tagged mempty -instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where- taggedObjectEnc' opts targs contentsFieldName =- Tagged . (\z -> E.comma >< toEncoding contentsFieldName >< E.colon >< z) .- gToEncoding opts targs+instance ( RecordToPairs enc pairs arity f+ ) => TaggedObject' enc pairs arity f True+ where+ taggedObject' opts targs _ = Tagged . recordToPairs opts targs -------------------------------------------------------------------------------- @@ -942,23 +897,35 @@ instance (Constructor c) => GetConName (C1 c a) where getConName = conName + -------------------------------------------------------------------------------- -class TwoElemArrayObj arity f where- twoElemArrayObj :: Options -> ToArgs Value arity a- -> f a -> V.Vector Value+-- Reflection of SumEncoding variants -instance ( TwoElemArrayObj arity a- , TwoElemArrayObj arity b- ) => TwoElemArrayObj arity (a :+: b) where- twoElemArrayObj opts targs (L1 x) = twoElemArrayObj opts targs x- twoElemArrayObj opts targs (R1 x) = twoElemArrayObj opts targs x+data ObjectWithSingleField+data TwoElemArray+data UntaggedValue -instance ( GToJSON arity a- , ConsToJSON arity a+--------------------------------------------------------------------------------++class SumToJSON' s enc arity f where+ sumToJSON' :: Options -> ToArgs enc arity a+ -> f a -> Tagged s enc++instance ( SumToJSON' s enc arity a+ , SumToJSON' s enc arity b+ ) => SumToJSON' s enc arity (a :+: b)+ where+ sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x+ sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x++--------------------------------------------------------------------------------++instance ( GToJSON Value arity a+ , ConsToJSON Value arity a , Constructor c- ) => TwoElemArrayObj arity (C1 c a) where- twoElemArrayObj opts targs x = V.create $ do+ ) => SumToJSON' TwoElemArray Value arity (C1 c a) where+ sumToJSON' opts targs x = Tagged $ Array $ V.create $ do mv <- VM.unsafeNew 2 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts $ conName (undefined :: t c a p)@@ -967,149 +934,103 @@ -------------------------------------------------------------------------------- -class TwoElemArrayEnc arity f where- twoElemArrayEnc :: Options -> ToArgs Encoding arity a- -> f a -> Encoding--instance ( TwoElemArrayEnc arity a- , TwoElemArrayEnc arity b- ) => TwoElemArrayEnc arity (a :+: b) where- twoElemArrayEnc opts targs (L1 x) = twoElemArrayEnc opts targs x- twoElemArrayEnc opts targs (R1 x) = twoElemArrayEnc opts targs x--instance ( GToEncoding arity a- , ConsToEncoding arity a+instance ( GToJSON Encoding arity a+ , ConsToJSON Encoding arity a , Constructor c- ) => TwoElemArrayEnc arity (C1 c a) where- twoElemArrayEnc opts targs x = E.list id+ ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)+ where+ sumToJSON' opts targs x = Tagged $ E.list id [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))- , gToEncoding opts targs x+ , gToJSON opts targs x ] -------------------------------------------------------------------------------- -class ConsToJSON arity f where- consToJSON :: Options -> ToArgs Value arity a- -> f a -> Value+class ConsToJSON enc arity f where+ consToJSON :: Options -> ToArgs enc arity a+ -> f a -> enc -class ConsToJSON' arity f isRecord where- consToJSON' :: Options -> ToArgs Value arity a+class ConsToJSON' enc arity f isRecord where+ consToJSON' :: Options -> ToArgs enc arity a -> Bool -- ^ Are we a record with one field?- -> f a -> Tagged isRecord Value+ -> f a -> Tagged isRecord enc -instance ( IsRecord f isRecord- , ConsToJSON' arity f isRecord- ) => ConsToJSON arity f where+instance ( IsRecord f isRecord+ , ConsToJSON' enc arity f isRecord+ ) => ConsToJSON enc arity f+ where consToJSON opts targs =- (unTagged :: Tagged isRecord Value -> Value)+ (unTagged :: Tagged isRecord enc -> enc) . consToJSON' opts targs (isUnary (undefined :: f a))+ {-# INLINE consToJSON #-} -instance (RecordToPairs arity f) => ConsToJSON' arity f True where- consToJSON' opts targs isUn f = let- vals = toList $ recordToPairs opts targs f- in case (unwrapUnaryRecords opts,isUn,vals) of- (True,True,[(_,val)]) -> Tagged val- _ -> Tagged $ object vals+instance ( RecordToPairs enc pairs arity f+ , FromPairs enc pairs+ , GToJSON enc arity f+ ) => ConsToJSON' enc arity f True+ where+ consToJSON' opts targs isUn =+ Tagged .+ case (isUn, unwrapUnaryRecords opts) of+ (True, True) -> gToJSON opts targs+ _ -> fromPairs . recordToPairs opts targs+ {-# INLINE consToJSON' #-} -instance GToJSON arity f => ConsToJSON' arity f False where+instance GToJSON enc arity f => ConsToJSON' enc arity f False where consToJSON' opts targs _ = Tagged . gToJSON opts targs------------------------------------------------------------------------------------class ConsToEncoding arity f where- consToEncoding :: Options -> ToArgs Encoding arity a- -> f a -> Encoding--class ConsToEncoding' arity f isRecord where- consToEncoding' :: Options -> ToArgs Encoding arity a- -> Bool -- ^ Are we a record with one field?- -> f a -> Tagged isRecord Encoding--instance ( IsRecord f isRecord- , ConsToEncoding' arity f isRecord- ) => ConsToEncoding arity f where- consToEncoding opts targs =- (unTagged :: Tagged isRecord Encoding -> Encoding)- . consToEncoding' opts targs (isUnary (undefined :: f a))--instance (RecordToEncoding arity f) => ConsToEncoding' arity f True where- consToEncoding' opts targs isUn x =- let (enc, mbVal) = recordToEncoding opts targs x- in case (unwrapUnaryRecords opts, isUn, mbVal) of- (True, True, Just val) -> Tagged val- _ -> Tagged $ E.wrapObject enc--instance GToEncoding arity f => ConsToEncoding' arity f False where- consToEncoding' opts targs _ = Tagged . gToEncoding opts targs------------------------------------------------------------------------------------class RecordToPairs arity f where- recordToPairs :: Options -> ToArgs Value arity a- -> f a -> DList Pair--instance ( RecordToPairs arity a- , RecordToPairs arity b- ) => RecordToPairs arity (a :*: b) where- recordToPairs opts targs (a :*: b) = recordToPairs opts targs a <>- recordToPairs opts targs b--instance (Selector s, GToJSON arity a) => RecordToPairs arity (S1 s a) where- recordToPairs = fieldToPair--instance OVERLAPPING_ (Selector s, ToJSON a) =>- RecordToPairs arity (S1 s (K1 i (Maybe a))) where- recordToPairs opts _ (M1 k1) | omitNothingFields opts- , K1 Nothing <- k1 = DList.empty- recordToPairs opts targs m1 = fieldToPair opts targs m1--fieldToPair :: (Selector s, GToJSON arity a)- => Options -> ToArgs Value arity p- -> S1 s a p -> DList Pair-fieldToPair opts targs m1 = pure ( pack $ fieldLabelModifier opts $ selName m1- , gToJSON opts targs (unM1 m1)- )+ {-# INLINE consToJSON' #-} -------------------------------------------------------------------------------- -class RecordToEncoding arity f where+class RecordToPairs enc pairs arity f where -- 1st element: whole thing -- 2nd element: in case the record has only 1 field, just the value -- of the field (without the key); 'Nothing' otherwise- recordToEncoding :: Options -> ToArgs Encoding arity a- -> f a -> (Encoding, Maybe Encoding)--instance ( RecordToEncoding arity a- , RecordToEncoding arity b- ) => RecordToEncoding arity (a :*: b) where- recordToEncoding opts targs (a :*: b) | omitNothingFields opts =- (E.econcat $ intersperse E.comma $- filter (not . E.nullEncoding)- [ fst (recordToEncoding opts targs a)- , fst (recordToEncoding opts targs b) ]- , Nothing)- recordToEncoding opts targs (a :*: b) =- (fst (recordToEncoding opts targs a) >< E.comma ><- fst (recordToEncoding opts targs b),- Nothing)+ recordToPairs :: Options -> ToArgs enc arity a+ -> f a -> pairs +instance ( Monoid pairs+ , RecordToPairs enc pairs arity a+ , RecordToPairs enc pairs arity b+ ) => RecordToPairs enc pairs arity (a :*: b)+ where+ recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =+ pairsOf a <> pairsOf b+ where+ pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs+ pairsOf = recordToPairs opts targs+ {-# INLINE recordToPairs #-} -instance (Selector s, GToEncoding arity a) => RecordToEncoding arity (S1 s a) where- recordToEncoding = fieldToEncoding+instance ( Selector s+ , GToJSON enc arity a+ , GKeyValue enc pairs+ ) => RecordToPairs enc pairs arity (S1 s a)+ where+ recordToPairs = fieldToPair+ {-# INLINE recordToPairs #-} -instance OVERLAPPING_ (Selector s, ToJSON a) =>- RecordToEncoding arity (S1 s (K1 i (Maybe a))) where- recordToEncoding opts _ (M1 k1) | omitNothingFields opts- , K1 Nothing <- k1 = (E.empty, Nothing)- recordToEncoding opts targs m1 = fieldToEncoding opts targs m1+instance OVERLAPPING_+ ( Selector s+ , GToJSON enc arity (K1 i (Maybe a))+ , GKeyValue enc pairs+ , Monoid pairs+ ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))+ where+ recordToPairs opts _ (M1 k1) | omitNothingFields opts+ , K1 Nothing <- k1 = mempty+ recordToPairs opts targs m1 = fieldToPair opts targs m1+ {-# INLINE recordToPairs #-} -fieldToEncoding :: (Selector s, GToEncoding arity a)- => Options -> ToArgs Encoding arity p- -> S1 s a p -> (Encoding, Maybe Encoding)-fieldToEncoding opts targs m1 =- let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)- valueBuilder = gToEncoding opts targs (unM1 m1)- in (keyBuilder >< E.colon >< valueBuilder, Just valueBuilder)+fieldToPair :: (Selector s+ , GToJSON enc arity a+ , GKeyValue enc pairs)+ => Options -> ToArgs enc arity p+ -> S1 s a p -> pairs+fieldToPair opts targs m1 =+ let key = fieldLabelModifier opts (selName m1)+ value = gToJSON opts targs (unM1 m1)+ in key `gPair` value+{-# INLINE fieldToPair #-} -------------------------------------------------------------------------------- @@ -1133,7 +1054,7 @@ lenR = len - lenL ixR = ix + lenL -instance OVERLAPPABLE_ (GToJSON arity a) => WriteProduct arity a where+instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where writeProduct opts targs mv ix _ = VM.unsafeWrite mv ix . gToJSON opts targs @@ -1154,109 +1075,38 @@ encodeProduct opts targs a >*< encodeProduct opts targs b -instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where- encodeProduct opts targs a = E.retagEncoding $ gToEncoding opts targs a+instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where+ encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a -------------------------------------------------------------------------------- -class ObjectWithSingleFieldObj arity f where- objectWithSingleFieldObj :: Options -> ToArgs Value arity a- -> f a -> Object--instance ( ObjectWithSingleFieldObj arity a- , ObjectWithSingleFieldObj arity b- ) => ObjectWithSingleFieldObj arity (a :+: b) where- objectWithSingleFieldObj opts targs (L1 x) =- objectWithSingleFieldObj opts targs x- objectWithSingleFieldObj opts targs (R1 x) =- objectWithSingleFieldObj opts targs x--instance ( GToJSON arity a- , ConsToJSON arity a+instance ( GToJSON enc arity a+ , ConsToJSON enc arity a+ , FromPairs enc pairs+ , GKeyValue enc pairs , Constructor c- ) => ObjectWithSingleFieldObj arity (C1 c a) where- objectWithSingleFieldObj opts targs = H.singleton typ . gToJSON opts targs+ ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)+ where+ sumToJSON' opts targs =+ Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs where- typ = pack $ constructorTagModifier opts $+ typ = constructorTagModifier opts $ conName (undefined :: t c a p) -------------------------------------------------------------------------------- -class ObjectWithSingleFieldEnc arity f where- objectWithSingleFieldEnc :: Options -> ToArgs Encoding arity a- -> f a -> Encoding--instance ( ObjectWithSingleFieldEnc arity a- , ObjectWithSingleFieldEnc arity b- ) => ObjectWithSingleFieldEnc arity (a :+: b) where- objectWithSingleFieldEnc opts targs (L1 x) =- objectWithSingleFieldEnc opts targs x- objectWithSingleFieldEnc opts targs (R1 x) =- objectWithSingleFieldEnc opts targs x--instance ( GToEncoding arity a- , ConsToEncoding arity a- , Constructor c- ) => ObjectWithSingleFieldEnc arity (C1 c a) where- objectWithSingleFieldEnc opts targs v = E.pairs (E.pair key val)- where- key :: Text- key = pack (constructorTagModifier opts (conName (undefined :: t c a p)))- val :: Encoding' Value- val = gToEncoding opts targs v------------------------------------------------------------------------------------class UntaggedValueObj arity f where- untaggedValueObj :: Options -> ToArgs Value arity a- -> f a -> Value--instance- ( UntaggedValueObj arity a- , UntaggedValueObj arity b- ) => UntaggedValueObj arity (a :+: b)- where- untaggedValueObj opts targs (L1 x) = untaggedValueObj opts targs x- untaggedValueObj opts targs (R1 x) = untaggedValueObj opts targs x- instance OVERLAPPABLE_- ( GToJSON arity a- , ConsToJSON arity a- ) => UntaggedValueObj arity (C1 c a) where- untaggedValueObj = gToJSON--instance OVERLAPPING_- ( Constructor c )- => UntaggedValueObj arity (C1 c U1)- where- untaggedValueObj opts _ _ = toJSON $- constructorTagModifier opts $ conName (undefined :: t c U1 p)------------------------------------------------------------------------------------class UntaggedValueEnc arity f where- untaggedValueEnc :: Options -> ToArgs Encoding arity a- -> f a -> Encoding-instance- ( UntaggedValueEnc arity a- , UntaggedValueEnc arity b- ) => UntaggedValueEnc arity (a :+: b)- where- untaggedValueEnc opts targs (L1 x) = untaggedValueEnc opts targs x- untaggedValueEnc opts targs (R1 x) = untaggedValueEnc opts targs x--instance OVERLAPPABLE_- ( GToEncoding arity a- , ConsToEncoding arity a- ) => UntaggedValueEnc arity (C1 c a)+ ( ConsToJSON enc arity a+ ) => SumToJSON' UntaggedValue enc arity (C1 c a) where- untaggedValueEnc = gToEncoding+ sumToJSON' opts targs = Tagged . gToJSON opts targs instance OVERLAPPING_- ( Constructor c )- => UntaggedValueEnc arity (C1 c U1)+ ( Constructor c+ , FromString enc+ ) => SumToJSON' UntaggedValue enc arity (C1 c U1) where- untaggedValueEnc opts _ _ = toEncoding $+ sumToJSON' opts _ _ = Tagged . fromString $ constructorTagModifier opts $ conName (undefined :: t c U1 p) -------------------------------------------------------------------------------@@ -2834,3 +2684,23 @@ copyBytes pf (pbuf `plusPtr` o) l copyChunks lbs' (pf `plusPtr` l) #endif++--------------------------------------------------------------------------------++class Monoid pairs => FromPairs enc pairs | enc -> pairs where+ fromPairs :: pairs -> enc++instance FromPairs Encoding Series where+ fromPairs = E.pairs++instance FromPairs Value (DList Pair) where+ fromPairs = object . toList++class Monoid kv => GKeyValue v kv where+ gPair :: String -> v -> kv++instance ToJSON v => GKeyValue v (DList Pair) where+ gPair k v = DList.singleton (pack k .= v)++instance GKeyValue Encoding Series where+ gPair = E.pairStr
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.1.2.0+version: 1.2.0.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -74,13 +74,13 @@ manual: False flag cffi- description: Controls whether to include c-ffi bits or pure haskell- default: True+ description: Controls whether to include c-ffi bits or pure haskell. Default to False for security.+ default: False manual: True library default-language: Haskell2010- hs-source-dirs: .+ hs-source-dirs: . attoparsec-iso8601/ exposed-modules: Data.Aeson@@ -109,14 +109,16 @@ Data.Aeson.Types.ToJSON Data.Aeson.Types.Class Data.Aeson.Types.Internal+ Data.Attoparsec.Time+ Data.Attoparsec.Time.Internal build-depends: attoparsec >= 0.13.0.1, base >= 4.5 && < 5, base-compat >= 0.9.1 && < 0.10,- containers >= 0.2.4.1,- deepseq >= 1.3,- dlist >= 0.2,+ containers >= 0.4.2,+ deepseq >= 1.3 && < 1.5,+ dlist >= 0.6, ghc-prim >= 0.2, hashable >= 1.1.2.0, scientific >= 0.3.4.7 && < 0.4,@@ -125,15 +127,15 @@ text >= 1.1.1.0, time >= 1.1.1.4, time-locale-compat >= 0.1.1 && < 0.2,- unordered-containers >= 0.2.5.0,+ unordered-containers >= 0.2.5.0 && < 0.3, uuid-types >= 1.0.3 && <1.1, vector >= 0.8 if flag(bytestring-builder)- build-depends: bytestring >= 0.9 && < 0.10.4,+ build-depends: bytestring >= 0.9.2 && < 0.10.4, bytestring-builder >= 0.10.4 && < 1 else- build-depends: bytestring >= 0.10.4+ build-depends: bytestring >= 0.10.4 && < 0.11 if !impl(ghc >= 8.0) -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9@@ -202,7 +204,7 @@ attoparsec, base, base-compat,- base-orphans >= 0.5.3 && <0.6,+ base-orphans >= 0.5.3 && <0.7, base16-bytestring, containers, directory,
+ attoparsec-iso8601/Data/Attoparsec/Time.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Data.Aeson.Parser.Time+-- Copyright: (c) 2015-2016 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: experimental+-- Portability: portable+--+-- Parsers for parsing dates and times.++module Data.Attoparsec.Time+ (+ day+ , localTime+ , timeOfDay+ , timeZone+ , utcTime+ , zonedTime+ ) where++import Prelude ()+import Prelude.Compat++import Control.Applicative ((<|>))+import Control.Monad (void, when)+import Data.Attoparsec.Text as A+import Data.Attoparsec.Time.Internal (toPico)+import Data.Bits ((.&.))+import Data.Char (isDigit, ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar (Day, fromGregorianValid)+import Data.Time.Clock (UTCTime(..))+import qualified Data.Text as T+import qualified Data.Time.LocalTime as Local++-- | Parse a date of the form @[+,-]YYYY-MM-DD@.+day :: Parser Day+day = do+ absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id+ y <- decimal <* char '-'+ m <- twoDigits <* char '-'+ d <- twoDigits+ maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+ a <- digit+ b <- digit+ let c2d c = ord c .&. 15+ return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+ h <- twoDigits+ m <- char ':' *> twoDigits+ s <- option 0 (char ':' *> seconds)+ if h < 24 && m < 60 && s < 61+ then return (Local.TimeOfDay h m s)+ else fail "invalid time"++data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+ real <- twoDigits+ mc <- peekChar+ case mc of+ Just '.' -> do+ t <- anyChar *> takeWhile1 isDigit+ return $! parsePicos real t+ _ -> return $! fromIntegral real+ where+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+ where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t+ step ma@(T m a) c+ | m <= 0 = ma+ | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+ let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)+ maybeSkip ' '+ ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ mm <- peekChar+ m <- case mm of+ Just ':' -> anyChar *> twoDigits+ Just d | isDigit d -> twoDigits+ _ -> return 0+ let off | ch == '-' = negate off0+ | otherwise = off0+ off0 = h * 60 + m+ case undefined of+ _ | off == 0 ->+ return Nothing+ | off < -720 || off > 840 || m > 59 ->+ fail "invalid time zone offset"+ | otherwise ->+ let !tz = Local.minutesToTimeZone off+ in return (Just tz)++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.+-- The space may be replaced with a @T@. The number of seconds is optional+-- and may be followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+ where daySep = satisfy (\c -> c == 'T' || c == ' ')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+ lt@(Local.LocalTime d t) <- localTime+ mtz <- timeZone+ case mtz of+ Nothing -> let !tt = Local.timeOfDayToTime t+ in return (UTCTime d tt)+ Just tz -> return $! Local.localTimeToUTC tz lt++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM Z@+-- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""
+ attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}++-- |+-- Module: Data.Aeson.Internal.Time+-- Copyright: (c) 2015-2016 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: experimental+-- Portability: portable++module Data.Attoparsec.Time.Internal+ (+ TimeOfDay64(..)+ , fromPico+ , toPico+ , diffTimeOfDay64+ , toTimeOfDay64+ ) where++import Prelude ()+import Prelude.Compat++import Data.Int (Int64)+import Data.Time+import Unsafe.Coerce (unsafeCoerce)++#if MIN_VERSION_base(4,7,0)++import Data.Fixed (Pico, Fixed(MkFixed))++toPico :: Integer -> Pico+toPico = MkFixed++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i++#else++import Data.Fixed (Pico)++toPico :: Integer -> Pico+toPico = unsafeCoerce++fromPico :: Pico -> Integer+fromPico = unsafeCoerce++#endif++-- | Like TimeOfDay, but using a fixed-width integer for seconds.+data TimeOfDay64 = TOD {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int+ {-# UNPACK #-} !Int64++diffTimeOfDay64 :: DiffTime -> TimeOfDay64+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000+ (m,s) = mp `quotRem` 60000000000000+ pico = unsafeCoerce t :: Integer++toTimeOfDay64 :: TimeOfDay -> TimeOfDay64+toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))
benchmarks/AesonCompareAutoInstances.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} module Main (main) where@@ -7,17 +7,25 @@ import Prelude () import Prelude.Compat +import Control.Monad import Control.DeepSeq (NFData, rnf, deepseq) import Criterion.Main hiding (defaultOptions)-import Data.Aeson.Encode+import Data.Aeson+import Data.Aeson.Encoding import Data.Aeson.TH import Data.Aeson.Types+import Data.ByteString.Lazy (ByteString) import Data.Data (Data) import Data.Typeable (Typeable)-import GHC.Generics (Generic)+import GHC.Generics (Generic, Rep) import Options-import qualified Data.Aeson.Generic as G (fromJSON, toJSON) +toBS :: Encoding -> ByteString+toBS = encodingToLazyByteString++gEncode :: (Generic a, GToEncoding Zero (Rep a)) => a -> ByteString+gEncode = toBS . genericToEncoding opts+ -------------------------------------------------------------------------------- data D a = Nullary@@ -27,7 +35,7 @@ , testTwo :: Bool , testThree :: D a }- deriving (Show, Eq, Data, Typeable)+ deriving (Show, Eq) deriveJSON opts ''D @@ -60,7 +68,7 @@ , testTwo' :: Bool , testThree' :: D' a }- deriving (Show, Eq, Generic, Data, Typeable)+ deriving (Show, Eq, Generic) instance ToJSON a => ToJSON (D' a) where toJSON = genericToJSON opts@@ -96,7 +104,7 @@ , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int- } deriving (Show, Eq, Generic, Data, Typeable)+ } deriving (Show, Eq, Generic) instance NFData BigRecord @@ -106,15 +114,23 @@ 16 17 18 19 20 21 22 23 24 25 +return []+ gBigRecordToJSON :: BigRecord -> Value gBigRecordToJSON = genericToJSON opts +gBigRecordEncode :: BigRecord -> ByteString+gBigRecordEncode = gEncode+ gBigRecordFromJSON :: Value -> Result BigRecord gBigRecordFromJSON = parse $ genericParseJSON opts thBigRecordToJSON :: BigRecord -> Value thBigRecordToJSON = $(mkToJSON opts ''BigRecord) +thBigRecordEncode :: BigRecord -> ByteString+thBigRecordEncode = toBS . $(mkToEncoding opts ''BigRecord)+ thBigRecordFromJSON :: Value -> Result BigRecord thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord) @@ -126,7 +142,7 @@ !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int !Int- deriving (Show, Eq, Generic, Data, Typeable)+ deriving (Show, Eq, Generic) instance NFData BigProduct @@ -136,15 +152,23 @@ 16 17 18 19 20 21 22 23 24 25 +return []+ gBigProductToJSON :: BigProduct -> Value gBigProductToJSON = genericToJSON opts +gBigProductEncode :: BigProduct -> ByteString+gBigProductEncode = gEncode+ gBigProductFromJSON :: Value -> Result BigProduct gBigProductFromJSON = parse $ genericParseJSON opts thBigProductToJSON :: BigProduct -> Value thBigProductToJSON = $(mkToJSON opts ''BigProduct) +thBigProductEncode :: BigProduct -> ByteString+thBigProductEncode = toBS . $(mkToEncoding opts ''BigProduct)+ thBigProductFromJSON :: Value -> Result BigProduct thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct) @@ -155,21 +179,29 @@ | F11 | F12 | F13 | F14 | F15 | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 | F24 | F25- deriving (Show, Eq, Generic, Data, Typeable)+ deriving (Show, Eq, Generic) instance NFData BigSum bigSum = F25 +return []+ gBigSumToJSON :: BigSum -> Value gBigSumToJSON = genericToJSON opts +gBigSumEncode :: BigSum -> ByteString+gBigSumEncode = gEncode+ gBigSumFromJSON :: Value -> Result BigSum gBigSumFromJSON = parse $ genericParseJSON opts thBigSumToJSON :: BigSum -> Value thBigSumToJSON = $(mkToJSON opts ''BigSum) +thBigSumEncode :: BigSum -> ByteString+thBigSumEncode = toBS . $(mkToEncoding opts ''BigSum)+ thBigSumFromJSON :: Value -> Result BigSum thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum) @@ -177,53 +209,74 @@ type FJ a = Value -> Result a -main :: IO ()-main = defaultMain+runBench :: IO ()+runBench = defaultMain [ let v = toJSON d in (d, d', v) `deepseq` bgroup "D" [ group "toJSON" (nf toJSON d)- (nf G.toJSON d) (nf toJSON d')+ , group "encode" (nf encode d)+ (nf encode d') , group "fromJSON" (nf ( fromJSON :: FJ T ) v)- (nf (G.fromJSON :: FJ T ) v) (nf ( fromJSON :: FJ T') v) ] , let v = thBigRecordToJSON bigRecord in bigRecord `deepseq` v `deepseq` bgroup "BigRecord" [ group "toJSON" (nf thBigRecordToJSON bigRecord)- (nf G.toJSON bigRecord)- (nf gBigRecordToJSON bigRecord)+ (nf gBigRecordToJSON bigRecord)+ , group "encode" (nf thBigRecordEncode bigRecord)+ (nf gBigRecordEncode bigRecord) , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)- (nf (G.fromJSON :: FJ BigRecord) v)- (nf (gBigRecordFromJSON :: FJ BigRecord) v)+ (nf ( gBigRecordFromJSON :: FJ BigRecord) v) ] , let v = thBigProductToJSON bigProduct in bigProduct `deepseq` v `deepseq` bgroup "BigProduct" [ group "toJSON" (nf thBigProductToJSON bigProduct)- (nf G.toJSON bigProduct) (nf gBigProductToJSON bigProduct)+ , group "encode" (nf thBigProductEncode bigProduct)+ (nf gBigProductEncode bigProduct) , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)- (nf (G.fromJSON :: FJ BigProduct) v) (nf (gBigProductFromJSON :: FJ BigProduct) v) ] , let v = thBigSumToJSON bigSum in bigSum `deepseq` v `deepseq` bgroup "BigSum" [ group "toJSON" (nf thBigSumToJSON bigSum)- (nf G.toJSON bigSum) (nf gBigSumToJSON bigSum)+ , group "encode" (nf thBigSumEncode bigSum)+ (nf gBigSumEncode bigSum) , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)- (nf (G.fromJSON :: FJ BigSum) v) (nf (gBigSumFromJSON :: FJ BigSum) v) ] ] -group n th syb gen = bcompare- [ bgroup n [ bench "th" th- , bench "syb" syb- , bench "generic" gen- ]- ]+group n th gen = bgroup n [ bench "th" th+ , bench "generic" gen+ ]++sanityCheck = do+ check d toJSON fromJSON encode+ check d' toJSON fromJSON encode+ check bigRecord thBigRecordToJSON thBigRecordFromJSON thBigRecordEncode+ check bigRecord gBigRecordToJSON gBigRecordFromJSON gBigRecordEncode+ check bigProduct thBigProductToJSON thBigProductFromJSON thBigProductEncode+ check bigProduct gBigProductToJSON gBigProductFromJSON gBigProductEncode+ check bigSum thBigSumToJSON thBigSumFromJSON thBigSumEncode+ check bigSum gBigSumToJSON gBigSumFromJSON gBigSumEncode++check :: (Show a, Eq a)+ => a -> (a -> Value) -> (Value -> Result a) -> (a -> ByteString) -> IO ()+check x toJSON fromJSON encode = do+ unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x+ unless (Success x == (decode' . encode) x) $ fail $ "encode: " ++ show x+ where+ decode' s = case decode s of+ Just v -> fromJSON v+ Nothing -> fail ""++main = do+ sanityCheck+ runBench
benchmarks/Options.hs view
@@ -1,4 +1,4 @@-module Options () where+module Options where import Prelude () import Prelude.Compat
benchmarks/aeson-benchmarks.cabal view
@@ -10,7 +10,7 @@ manual: False library- hs-source-dirs: .. . ../ffi ../pure+ hs-source-dirs: .. . ../ffi ../pure ../attoparsec-iso8601 c-sources: ../cbits/unescape_string.c exposed-modules: Data.Aeson@@ -34,6 +34,8 @@ Data.Aeson.Types.Generic Data.Aeson.Types.Internal Data.Aeson.Types.ToJSON+ Data.Attoparsec.Time+ Data.Attoparsec.Time.Internal build-depends: attoparsec >= 0.13.0.1,@@ -179,7 +181,7 @@ executable aeson-benchmark-dates main-is: Dates.hs- ghc-options: -Wall -O2 -rtsopts -fsimpl-tick-factor=200+ ghc-options: -Wall -O2 -rtsopts build-depends: base, base-compat,
changelog.md view
@@ -1,5 +1,17 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +## 1.2.0.0++* `tagSingleConstructors`, an option to encode single-constructor types as tagged sums was added to `Options`. It is disabled by default for backward compatibility.++* The `cffi` flag is now turned on by default, this means C FFI code is no longer used by default. You can flip the flag to get C implementation.++* The `Options` constructor is no longer exposed to prevent new options from being breaking changes, use `defaultOptions` instead.++* The contents of `GToJSON` and `GToEncoding` are no longer exposed.++* Some INLINE pragmas were removed to avoid GHC running out of simplifier ticks.+ ### 1.1.2.0 * Fix an accidental change in the format of `deriveJSON`. Thanks to Xia Li-yao!
pure/Data/Aeson/Parser/UnescapePure.hs view
@@ -1,3 +1,10 @@+-- WARNING: This file is security sensitive as it uses unsafeWrite which does+-- not check bounds. Any changes should be made with care and we would love to+-- get informed about them, just cc us in any PR targetting this file: @eskimor @jprider63+-- We would be happy to review the changes!++-- The security check at the end (pos > length) only works if pos grows+-- monotonously, if this condition does not hold, the check is flawed. module Data.Aeson.Parser.UnescapePure ( unescapeText@@ -145,8 +152,8 @@ dest <- A.new len (pos, finalState) <- B.foldl' (f' dest) (return (0, StateNone)) bs - -- Check final state.- when ( finalState /= StateNone)+ -- Check final state. Currently pos gets only increased over time, so this check should catch overflows.+ when ( finalState /= StateNone || pos > len) throwDecodeError done dest pos -- TODO: pos, pos-1??? XXX@@ -247,8 +254,6 @@ writeAndReturn dest pos u StateNone {-# INLINE f #-}--{-# INLINE unescapeText' #-} write :: A.MArray s -> Int -> Word16 -> ST s () write dest pos char =
stack-lts6.yaml view
@@ -1,11 +1,14 @@ resolver: lts-6.30 packages: - '.'+- attoparsec-iso8601 extra-deps: - semigroups-0.18.2 - integer-logarithms-1 flags: aeson:+ fast: true+ attoparsec-iso8601: fast: true semigroups: bytestring-builder: false
stack-lts7.yaml view
@@ -1,8 +1,11 @@ resolver: lts-7.19 packages: - '.'+- attoparsec-iso8601 extra-deps: - integer-logarithms-1 flags: aeson:+ fast: true+ attoparsec-iso8601: fast: true
stack-lts8.yaml view
@@ -1,6 +1,9 @@ resolver: lts-8.1 packages: - '.'+- attoparsec-iso8601 flags: aeson:+ fast: true+ attoparsec-iso8601: fast: true
stack-nightly.yaml view
@@ -1,8 +1,9 @@-resolver: nightly-2017-02-29+resolver: nightly-2017-03-25 packages: - '.'-extra-deps:-- integer-logarithms-1+- attoparsec-iso8601 flags: aeson:+ fast: true+ attoparsec-iso8601: fast: true
tests/Encoders.hs view
@@ -354,3 +354,31 @@ thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)++thOneConstructorToJSONTagged :: OneConstructor -> Value+thOneConstructorToJSONTagged = $(mkToJSON optsTagSingleConstructors ''OneConstructor)++thOneConstructorToEncodingTagged :: OneConstructor -> Encoding+thOneConstructorToEncodingTagged = $(mkToEncoding optsTagSingleConstructors ''OneConstructor)++thOneConstructorParseJSONTagged :: Value -> Parser OneConstructor+thOneConstructorParseJSONTagged = $(mkParseJSON optsTagSingleConstructors ''OneConstructor)+++gOneConstructorToJSONDefault :: OneConstructor -> Value+gOneConstructorToJSONDefault = genericToJSON defaultOptions++gOneConstructorToEncodingDefault :: OneConstructor -> Encoding+gOneConstructorToEncodingDefault = genericToEncoding defaultOptions++gOneConstructorParseJSONDefault :: Value -> Parser OneConstructor+gOneConstructorParseJSONDefault = genericParseJSON defaultOptions++gOneConstructorToJSONTagged :: OneConstructor -> Value+gOneConstructorToJSONTagged = genericToJSON optsTagSingleConstructors++gOneConstructorToEncodingTagged :: OneConstructor -> Encoding+gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors++gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor+gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors
tests/Options.hs view
@@ -42,3 +42,9 @@ optsUntaggedValue = optsDefault { sumEncoding = UntaggedValue }++optsTagSingleConstructors :: Options+optsTagSingleConstructors = optsDefault+ { tagSingleConstructors = True+ , allNullaryToStringTag = False+ }
tests/Properties.hs view
@@ -168,12 +168,15 @@ isTaggedObjectValue _ = False isNullaryTaggedObject :: Value -> Bool-isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj -isTaggedObject :: Value -> Bool-isTaggedObject (Object obj) = "tag" `H.member` obj-isTaggedObject _ = False+isTaggedObject :: Value -> Property+isTaggedObject = checkValue isTaggedObject' +isTaggedObject' :: Value -> Bool+isTaggedObject' (Object obj) = "tag" `H.member` obj+isTaggedObject' _ = False+ isObjectWithSingleField :: Value -> Bool isObjectWithSingleField (Object obj) = H.size obj == 1 isObjectWithSingleField _ = False@@ -338,6 +341,14 @@ #endif ] ]+ , testGroup "OneConstructor" [+ testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)+ , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)+ , testGroup "roundTrip" [+ testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)+ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)+ ]+ ] ] , testGroup "toEncoding" [ testProperty "NullaryString" $@@ -386,6 +397,11 @@ , testProperty "SomeTypeOmitNothingFields" $ gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields++ , testProperty "OneConstructorDefault" $+ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault+ , testProperty "OneConstructorTagged" $+ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged ] ] , testGroup "template-haskell" [@@ -440,8 +456,10 @@ ] , testGroup "OneConstructor" [ testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)+ , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged) , testGroup "roundTrip" [ testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)+ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged) ] ] ]@@ -484,8 +502,10 @@ , testProperty "SomeTypeObjectWithSingleField unary agree" $ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField - , testProperty "OneConstructor" $+ , testProperty "OneConstructorDefault" $ thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault+ , testProperty "OneConstructorTagged" $+ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged ] ] ]
tests/UnitTests.hs view
@@ -18,11 +18,11 @@ import Prelude.Compat import Control.Monad (forM, forM_)-import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, genericToEncoding, genericToJSON, object, withObject)+import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject) import Data.Aeson.Internal (JSONPathElement(..), formatError) import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1) import Data.Aeson.Text (encodeToTextBuilder)-import Data.Aeson.Types (Options(..), ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)+import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null), camelTo, camelTo2, defaultOptions, omitNothingFields, parse) import Data.Char (toUpper) import Data.Either.Compat (isLeft, isRight) import Data.Hashable (hash)@@ -92,6 +92,7 @@ , testCase "PR #455" pr455 , testCase "Unescape string (PR #477)" unescapeString , testCase "Show Options" showOptions+ , testGroup "SingleMaybeField" singleMaybeField ] roundTripCamel :: String -> Assertion@@ -493,10 +494,30 @@ ++ ", omitNothingFields = False" ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" ++ ", unwrapUnaryRecords = False"+ ++ ", tagSingleConstructors = False" ++ "}") (show defaultOptions) +newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }+ deriving (Eq, Show, Generic)++singleMaybeField :: [Test]+singleMaybeField = do+ (gName, gToJSON, gToEncoding, gFromJSON) <-+ [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))+ , ("th", toJSON, toEncoding, fromJSON) ]+ return $+ testCase gName $ do+ assertEqual "toJSON" Null (gToJSON v)+ assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v)+ assertEqual "fromJSON" (Success v) (gFromJSON Null)+ where+ v = SingleMaybeField Nothing+ opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}+ deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord deriveToJSON defaultOptions ''Foo deriveToJSON1 defaultOptions ''Foo++deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField