diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011, MailRank, Inc. 2014-2021 Aeson project contributors +Copyright (c) 2011, MailRank, Inc. 2014-2026 Aeson project contributors All rights reserved. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -14,14 +14,11 @@ Master [git repository](http://github.com/haskell/aeson): -* `git clone git://github.com/haskell/aeson.git` +* `git clone https://github.com/haskell/aeson.git` See what's changed in recent (and upcoming) releases: * https://github.com/haskell/aeson/blob/master/changelog.md - -(You can create and contribute changes using either git or Mercurial.) - # Authors diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,28 +1,32 @@ +cabal-version: 2.2 name: aeson -version: 2.1.2.1 -license: BSD3 +version: 2.3.1.0 +license: BSD-3-Clause license-file: LICENSE category: Text, Web, JSON copyright: - (c) 2011-2016 Bryan O'Sullivan - (c) 2011 MailRank, Inc. - + 2014-2026 Aeson project contributors, + 2011-2016 Bryan O'Sullivan, + 2011 MailRank, Inc. author: Bryan O'Sullivan -maintainer: Adam Bergmark -stability: experimental +maintainer: + Li-yao Xia , + Core Libraries Committee +stability: stable tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 + GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.7 - || ==9.4.4 + || ==9.2.8 + || ==9.4.8 + || ==9.6.6 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 synopsis: Fast JSON parsing and encoding -cabal-version: >=1.10 homepage: https://github.com/haskell/aeson bug-reports: https://github.com/haskell/aeson/issues build-type: Simple @@ -34,28 +38,18 @@ below. . (A note on naming: in Greek mythology, Aeson was the father of Jason.) - +extra-doc-files: + README.markdown + changelog.md extra-source-files: *.yaml benchmarks/json-data/*.json - cbits/*.c - changelog.md - README.markdown - src-ffi/Data/Aeson/Parser/*.hs - src-pure/Data/Aeson/Parser/*.hs tests/golden/*.expected tests/JSONTestSuite/results/*.tok tests/JSONTestSuite/results/*.txt tests/JSONTestSuite/test_parsing/*.json tests/JSONTestSuite/test_transform/*.json -flag cffi - description: - Controls whether to include c-ffi bits or pure haskell. Default to False for security. - - default: False - manual: True - flag ordered-keymap description: Use ordered @Data.Map.Strict@ for KeyMap implementation. default: True @@ -63,100 +57,93 @@ library default-language: Haskell2010 - hs-source-dirs: src attoparsec-iso8601/src + hs-source-dirs: src exposed-modules: Data.Aeson Data.Aeson.Decoding Data.Aeson.Decoding.ByteString Data.Aeson.Decoding.ByteString.Lazy + Data.Aeson.Decoding.Text Data.Aeson.Decoding.Tokens Data.Aeson.Encoding Data.Aeson.Encoding.Internal - Data.Aeson.Internal - Data.Aeson.Internal.Time Data.Aeson.Key Data.Aeson.KeyMap - Data.Aeson.Parser - Data.Aeson.Parser.Internal Data.Aeson.QQ.Simple + Data.Aeson.RFC8785 Data.Aeson.Text Data.Aeson.TH Data.Aeson.Types other-modules: + Data.Aeson.Decoding.Conversion Data.Aeson.Decoding.Internal Data.Aeson.Encoding.Builder Data.Aeson.Internal.ByteString Data.Aeson.Internal.Functions - Data.Aeson.Internal.Integer + Data.Aeson.Internal.Prelude + Data.Aeson.Internal.Scientific Data.Aeson.Internal.Text Data.Aeson.Internal.TH - Data.Aeson.Internal.Word8 + Data.Aeson.Internal.Unescape + Data.Aeson.Internal.UnescapeFromText Data.Aeson.Parser.Time - Data.Aeson.Parser.Unescape Data.Aeson.Types.Class Data.Aeson.Types.FromJSON Data.Aeson.Types.Generic Data.Aeson.Types.Internal Data.Aeson.Types.ToJSON - Data.Attoparsec.Time - Data.Attoparsec.Time.Internal -- GHC bundled libs build-depends: - base >=4.9.0.0 && <5 - , bytestring >=0.10.8.1 && <0.12 - , containers >=0.5.7.1 && <0.7 - , deepseq >=1.4.2.0 && <1.5 + , base >=4.12.0.0 && <5 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.6.0.1 && <0.9 + , deepseq >=1.4.4.0 && <1.6 , exceptions >=0.10.4 && <0.11 - , ghc-prim >=0.5.0.0 && <0.10 - , template-haskell >=2.11.0.0 && <2.20 - , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 - , time >=1.6.0.1 && <1.13 + , template-haskell >=2.14.0.0 && <2.25 + , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2 + , time >=1.8.0.2 && <1.16 -- Compat build-depends: - base-compat-batteries >=0.10.0 && <0.13 - , generically >=0.1 && <0.2 - , time-compat >=1.9.6 && <1.10 + , time-compat >=1.9.6 && <1.10 - if !impl(ghc >=8.6) - build-depends: contravariant >=1.4.1 && <1.6 + if !impl(ghc >=9.4) + build-depends: generically >=0.1 && <0.2 + if !impl(ghc >=9.0) + build-depends: integer-gmp + -- Other dependencies build-depends: - attoparsec >=0.14.2 && <0.15 - , data-fix >=0.3.2 && <0.4 - , dlist >=0.8.0.4 && <1.1 - , hashable >=1.3.5.0 && <1.5 - , indexed-traversable >=0.1.2 && <0.2 - , OneTuple >=0.3.1 && <0.4 - , primitive >=0.7.3.0 && <0.9 - , QuickCheck >=2.14.2 && <2.15 - , scientific >=0.3.7.0 && <0.4 - , semialign >=1.2 && <1.3 - , strict >=0.4 && <0.5 - , tagged >=0.8.6 && <0.9 - , text-short >=0.1.5 && <0.2 - , th-abstraction >=0.3.0.0 && <0.6 - , these >=1.1.1.1 && <1.2 - , unordered-containers >=0.2.10.0 && <0.3 - , uuid-types >=1.0.5 && <1.1 - , vector >=0.12.0.1 && <0.14 - , witherable >=0.4.2 && <0.5 + , character-ps ^>=0.1 + , data-fix ^>=0.3.2 + , dlist ^>=1.0 + , hashable ^>=1.4.6.0 || ^>=1.5.0.0 + , indexed-traversable ^>=0.1.2 + , integer-conversion ^>=0.1 + , integer-logarithms ^>=1.0.3.1 + , network-uri ^>=2.6.4.1 + , OneTuple ^>=0.4.1.1 + , primitive ^>=0.8.0.0 || ^>=0.9.0.0 + , QuickCheck ^>=2.14.3 || ^>=2.15 || ^>=2.16.0.0 || ^>=2.17.1.0 || ^>=2.18.0.0 + , scientific ^>=0.3.7.0 + , semialign ^>=1.3 || ^>=1.4 + , strict ^>=0.5 + , tagged ^>=0.8.7 + , text-iso8601 >=0.1.1 && < 0.3 + , text-short ^>=0.1.5 + , th-abstraction ^>=0.5.0.0 || ^>=0.6.0.0 || ^>=0.7.0.0 + , these ^>=1.2 + , unordered-containers ^>=0.2.10.0 + , uuid-types ^>=1.0.5 + , vector ^>=0.13.0.0 + , witherable ^>=0.4.2 || ^>=0.5 ghc-options: -Wall - if (impl(ghcjs) || !flag(cffi)) - hs-source-dirs: src-pure - other-modules: Data.Aeson.Parser.UnescapePure - - else - c-sources: cbits/unescape_string.c - cpp-options: -DCFFI - hs-source-dirs: src-ffi - other-modules: Data.Aeson.Parser.UnescapeFFI - build-depends: text <2.0 + -- String unescaping if flag(ordered-keymap) cpp-options: -DUSE_ORDEREDMAP=1 @@ -168,10 +155,12 @@ main-is: Tests.hs ghc-options: -Wall -threaded -rtsopts other-modules: + CastFloat DataFamilies.Encoders DataFamilies.Instances DataFamilies.Properties DataFamilies.Types + DoubleToScientific Encoders ErrorMessages Functions @@ -186,36 +175,51 @@ PropertyRTFunctors PropertyTH PropUtils + Regression.Issue351 + Regression.Issue571 + Regression.Issue687 Regression.Issue967 + Regression.Issue1138 + RFC8785 SerializationFormatSpec Types UnitTests + UnitTests.FromJSONKey + UnitTests.Hashable + UnitTests.KeyMapInsertWith + UnitTests.MonadFix + UnitTests.NoThunks UnitTests.NullaryConstructors + UnitTests.OmitNothingFieldsNote + UnitTests.OptionalFields + UnitTests.OptionalFields.Common + UnitTests.OptionalFields.Generics + UnitTests.OptionalFields.Manual + UnitTests.OptionalFields.TH + UnitTests.UTCTime build-depends: - aeson - , attoparsec + , aeson , base , base-compat - , base-orphans >=0.5.3 && <0.9 + , base-orphans >=0.5.3 && <0.10 , base16-bytestring , bytestring , containers , data-fix - , Diff >=0.4 && <0.5 + , Diff >=0.4 && <0.6 || ^>=1.0.2 , directory , dlist , filepath - , generic-deriving >=1.10 && <1.15 + , generic-deriving >=1.10 && <1.15 , generically - , ghc-prim >=0.2 , hashable , indexed-traversable - , integer-logarithms >=1 && <1.1 + , integer-logarithms >=1 && <1.1 + , network-uri , OneTuple - , primitive - , QuickCheck >=2.14.2 && <2.15 - , quickcheck-instances >=0.3.29 && <0.4 + , QuickCheck + , quickcheck-instances >=0.3.29 && <0.5 , scientific , strict , tagged @@ -223,7 +227,6 @@ , tasty-golden , tasty-hunit , tasty-quickcheck - , template-haskell , text , text-short , these @@ -233,6 +236,12 @@ , uuid-types , vector + if !impl(ghc >=9.0) + build-depends: integer-gmp + + if impl(ghc >=9.2 && <9.7) + build-depends: nothunks >=0.1.4 && <0.4 + source-repository head type: git - location: git://github.com/haskell/aeson.git + location: https://github.com/haskell/aeson.git diff --git a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs b/attoparsec-iso8601/src/Data/Attoparsec/Time.hs deleted file mode 100644 --- a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module: Data.Aeson.Parser.Time --- Copyright: (c) 2015-2016 Bryan O'Sullivan --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- Parsers for parsing dates and times. - -module Data.Attoparsec.Time - ( - day - , localTime - , timeOfDay - , timeZone - , utcTime - , zonedTime - , year - , month - , quarter - ) where - -import Prelude.Compat - -import Control.Applicative ((<|>)) -import Control.Monad (void, when) -import Data.Attoparsec.Text (Parser, char, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy) -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.Calendar.Compat (Year) -import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter) -import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid) -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@. --- --- The year must contain at least 4 digits, to avoid the Y2K problem: --- a two-digit year @YY@ may mean @YY@, @19YY@, or @20YY@, and we make it --- an error to prevent the ambiguity. --- Years from @0000@ to @0999@ must thus be zero-padded. --- The year may have more than 4 digits. -day :: Parser Day -day = do - absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id - y <- (year <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD" - m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD" - d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD" - maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d) - --- | Parse a month of the form @[+,-]YYYY-MM@. --- --- See also 'day' for details about the year format. -month :: Parser Month -month = do - absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id - y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM" - m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM" - maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m) - --- | Parse a quarter of the form @[+,-]YYYY-QN@. --- --- See also 'day' for details about the year format. -quarter :: Parser Quarter -quarter = do - absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id - y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM" - _ <- char 'q' <|> char 'Q' - q <- parseQ - return $! fromYearQuarter (absOrNeg y) q - where - parseQ = Q1 <$ char '1' - <|> Q2 <$ char '2' - <|> Q3 <$ char '3' - <|> Q4 <$ char '4' - --- | Parse a year @YYYY@, with at least 4 digits. Does not include any sign. --- --- Note: 'Year' is a type synonym for 'Integer'. --- --- @since 1.1.0.0 -year :: Parser Year -year = do - ds <- takeWhile1 isDigit - if T.length ds < 4 then - fail "expected year with at least 4 digits" - else - pure (txtToInteger ds) - --- | 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 "" - ------------------- Copy-pasted and adapted from base ------------------------ - -txtToInteger :: T.Text -> Integer -txtToInteger bs - | l > 40 = valInteger 10 l [ fromIntegral (ord w - 48) | w <- T.unpack bs ] - | otherwise = txtToIntegerSimple bs - where - l = T.length bs - -txtToIntegerSimple :: T.Text -> Integer -txtToIntegerSimple = T.foldl' step 0 where - step a b = a * 10 + fromIntegral (ord b - 48) -- 48 = '0' - --- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b --- digits are combined into a single radix b^2 digit. This process is --- repeated until we are left with a single digit. This algorithm --- performs well only on large inputs, so we use the simple algorithm --- for smaller inputs. -valInteger :: Integer -> Int -> [Integer] -> Integer -valInteger = go - where - go :: Integer -> Int -> [Integer] -> Integer - go _ _ [] = 0 - go _ _ [d] = d - go b l ds - | l > 40 = b' `seq` go b' l' (combine b ds') - | otherwise = valSimple b ds - where - -- ensure that we have an even number of digits - -- before we call combine: - ds' = if even l then ds else 0 : ds - b' = b * b - l' = (l + 1) `quot` 2 - - combine b (d1 : d2 : ds) = d `seq` (d : combine b ds) - where - d = d1 * b + d2 - combine _ [] = [] - combine _ [_] = errorWithoutStackTrace "this should not happen" - --- The following algorithm is only linear for types whose Num operations --- are in constant time. -valSimple :: Integer -> [Integer] -> Integer -valSimple base = go 0 - where - go r [] = r - go r (d : ds) = r' `seq` go r' ds - where - r' = r * base + fromIntegral d diff --git a/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs b/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs deleted file mode 100644 --- a/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} --- | --- Module: Data.Aeson.Internal.Time --- Copyright: (c) 2015-2016 Bryan O'Sullivan --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable - -module Data.Attoparsec.Time.Internal - ( - TimeOfDay64(..) - , fromPico - , toPico - , diffTimeOfDay64 - , toTimeOfDay64 - ) where - -import Prelude.Compat - -import Data.Fixed (Fixed(MkFixed), Pico) -import Data.Int (Int64) -import Data.Time (TimeOfDay(..)) -import Data.Time.Clock.Compat (DiffTime, diffTimeToPicoseconds) - -toPico :: Integer -> Pico -toPico = MkFixed -{-# DEPRECATED toPico "Use MkFixed" #-} - -fromPico :: Pico -> Integer -fromPico (MkFixed i) = i -{-# DEPRECATED fromPico "Use MkFixed" #-} - --- | Like TimeOfDay, but using a fixed-width integer for seconds. -data TimeOfDay64 = TOD {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int64 - -posixDayLength :: DiffTime -posixDayLength = 86400 - -diffTimeOfDay64 :: DiffTime -> TimeOfDay64 -diffTimeOfDay64 t - | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength)) - | otherwise = TOD (fromIntegral h) (fromIntegral m) s - where (h,mp) = pico t `quotRem` 3600000000000000 - (m,s) = mp `quotRem` 60000000000000 - pico = fromIntegral . diffTimeToPicoseconds - -toTimeOfDay64 :: TimeOfDay -> TimeOfDay64 -toTimeOfDay64 (TimeOfDay h m (MkFixed s)) = TOD h m (fromIntegral s) diff --git a/cbits/unescape_string.c b/cbits/unescape_string.c deleted file mode 100644 --- a/cbits/unescape_string.c +++ /dev/null @@ -1,149 +0,0 @@ -// Copyright (c) 2008-2009 Bjoern Hoehrmann -// Copyright (c) 2015, Ondrej Palkovsky -// Copyright (c) 2016, Winterland - -#include -#include -#include - - -#define UTF8_ACCEPT 0 -#define UTF8_REJECT 12 - -static const uint8_t utf8d[] = { - // The first part of the table maps bytes to character classes that - // to reduce the size of the transition table and create bitmasks. - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, - 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, - 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, - - // The second part is a transition table that maps a combination - // of a state of the automaton and a character class to a state. - 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, - 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, - 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, - 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, - 12,36,12,12,12,12,12,12,12,12,12,12, -}; - -static inline uint32_t decode(uint32_t* state, uint32_t* codep, uint32_t byte) { - uint32_t type = utf8d[byte]; - - *codep = (*state != UTF8_ACCEPT) ? - (byte & 0x3fu) | (*codep << 6) : - (0xff >> type) & (byte); - - *state = utf8d[256 + *state + type]; - return *state; -} - -static inline uint16_t decode_hex(uint32_t c) -{ - if (c >= '0' && c <= '9') return c - '0'; - else if (c >= 'a' && c <= 'f') return c - 'a' + 10; - else if (c >= 'A' && c <= 'F') return c - 'A' + 10; - return 0xFFFF; // Should not happen -} - -// Decode, return non-zero value on error -int _js_decode_string(uint16_t *const dest, size_t *destoff, - const uint8_t *s, const uint8_t *const srcend) -{ - uint16_t *d = dest + *destoff; - uint32_t state = 0; - uint32_t codepoint; - - uint8_t surrogate = 0; - uint16_t temp_hex = 0; - uint16_t unidata; - - // Optimized version of dispatch when just an ASCII char is expected - #define DISPATCH_ASCII(label) {\ - if (s >= srcend) {\ - return -1;\ - }\ - codepoint = *s++;\ - goto label;\ - } - - standard: - // Test end of stream - while (s < srcend) { - if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) { - if (state == UTF8_REJECT) { return -1; } - continue; - } - - if (codepoint == '\\') - DISPATCH_ASCII(backslash) - else if (codepoint <= 0xffff) - *d++ = (uint16_t) codepoint; - else { - *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10)); - *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF)); - } - } - *destoff = d - dest; - // Exit point - return (state != UTF8_ACCEPT); - backslash: - switch (codepoint) { - case '"': - case '\\': - case '/': - *d++ = (uint16_t) codepoint; - goto standard; - break; - case 'b': *d++ = '\b';goto standard; - case 'f': *d++ = '\f';goto standard; - case 'n': *d++ = '\n';goto standard; - case 'r': *d++ = '\r';goto standard; - case 't': *d++ = '\t';goto standard; - case 'u': DISPATCH_ASCII(unicode1);;break; - default: - return -1; - } - unicode1: - temp_hex = decode_hex(codepoint); - if (temp_hex == 0xFFFF) { return -1; } - else unidata = temp_hex << 12; - DISPATCH_ASCII(unicode2); - unicode2: - temp_hex = decode_hex(codepoint); - if (temp_hex == 0xFFFF) { return -1; } - else unidata |= temp_hex << 8; - DISPATCH_ASCII(unicode3); - unicode3: - temp_hex = decode_hex(codepoint); - if (temp_hex == 0xFFFF) { return -1; } - else unidata |= temp_hex << 4; - DISPATCH_ASCII(unicode4); - unicode4: - temp_hex = decode_hex(codepoint); - if (temp_hex == 0xFFFF) { return -1; } - else unidata |= temp_hex; - *d++ = (uint16_t) unidata; - - if (surrogate) { - if (unidata < 0xDC00 || unidata > 0xDFFF) // is not low surrogate - return -1; - surrogate = 0; - } else if (unidata >= 0xD800 && unidata <= 0xDBFF ) { // is high surrogate - surrogate = 1; - DISPATCH_ASCII(surrogate1); - } else if (unidata >= 0xDC00 && unidata <= 0xDFFF) { // is low surrogate - return -1; - } - goto standard; - surrogate1: - if (codepoint != '\\') { return -1; } - DISPATCH_ASCII(surrogate2) - surrogate2: - if (codepoint != 'u') { return -1; } - DISPATCH_ASCII(unicode1) -} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,110 @@ For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md). +### 2.3.1.0 + +* Add `FromJSONKey` instance for `Data.Fixed`. +* Add `ToJSON` and `FromJSON` instances for `Data.Complex`. +* Export `isEmptyArray` from `Data.Aeson.Types` module. +* Document that file decoding functions throw an exception when the file is missing. + +### 2.3.0.0 - 2026-05-21 + +* Fix parsing of fractional numbers to reject exponents smaller than -1024. + This breaking change affects `FromJSON` instances of `Fixed`, `DiffTime`, and `NominalDiffTime`, + rejecting more inputs. Error messages for `Ratio` and integral types are also slightly different + due to reusing the same bounding logic. +* Fix typo in error message: "~~Unespected~~ Unexpected control character while parsing string literal". +* Support nothunks 0.3. +* Unset executable permissions in some test files and remove a broken symlink. +* In `text-iso8601-0.2.0.0`: + - Reject years of more than 15 digits. + - Accept 24:00:00 time of day. + +### 2.2.5.0 + +* Support `semialign-1.4` + +### 2.2.4.0 + +* Check for control characters in text literals everywhere + +### 2.2.3.0 + +* Support `hashable-1.4.6.0`. +* Fix an issue where `Hashable Key` wasn't newtype instance over underlying `Text`, + so with `-ordered-keymap` there were correctness issues. +* Add instances for `Data.Semigroup.Sum`, `Product`, `Any`, `All` + +### 2.2.2.0 + +* Support GHC-8.6.5...9.10.1 +* Depend on `character-ps` instead of defining own Word8 pattern synonyms + +### 2.2.1.0 + +* Add `Data.Aeson.RFC8785`, a JSON Canonicalization Scheme implementation + https://datatracker.ietf.org/doc/html/rfc8785 +* Add Data.Aeson.Decoding.Text, decodeStrictText :: Text -> ... + + We avoid intermediate `ByteString` copy by not doing + `decode . TE.encodeUtf8`, but instead working on `Text` value directly. + As we know that the stream is valid Unicode (UTF8 or UTF16), + we can also take some shortcuts. + + One gotcha is that internal `Text` values (in `Key`s or `Value` `String`s) + will most likely retain the original input `Text` value (its underlying `Array`). + It shouldn't be an issue if the `Value` is then decoded to something else so these + `Text` values disappear, but if not (e.g. `Object` keys survive) + then users might want to use `Data.Text.copy`. + +### 2.2.0.0 + +* Rework how `omitNothingFields` works. Add `allowOmittedFields` as a parsing counterpart. + + New type-class members were added: `omitField :: a -> Bool` to `ToJSON` and `omittedField :: Maybe a` to `FromJSON`. + These control which fields can be omitted. + The `.:?=`, `.:!=` and `.?=` operators were added to make use of these new members. + + GHC.Generics and Template Haskell deriving has been updated accordingly. + Note: They behave as the parsers have been written with `.:!=`, i.e. + if the field value is `null` it's passed to the underlying parser. + This doesn't make difference for `Maybe` or `Option`, but does make for + types which parser doesn't accept `null`. + (`()` parser accepts everything and `Proxy` accepts `null). + + In addition to `Maybe` (and `Option`) fields the `Data.Monoid.First` and `Data.Monoid.Last` are also omitted, + as well as the most newtype wrappers, when their wrap omittable type (e.g. newtypes in `Data.Monoid` and `Data.Semigroup`, `Identity`, `Const`, `Tagged`, `Compose`). + Additionally "boring" types like `()` and `Proxy` are omitted as well. + As the omitting is now uniform, type arguments are also omitted (also in `Generic1` derived instance). + + Resolves issues: + + - [#687](https://github.com/haskell/aeson/issues/687) Derived ToJSON1 instance does not respect omitNothingFields = True, + - [#571](https://github.com/haskell/aeson/issues/571) omitNothingFields not used in Generic Decode, + - [#792](https://github.com/haskell/aeson/issues/792) Make Proxy fields optional. + +* Use `Data.Aeson.Decoding` parsing functions (introduced in version 2.1.2.0) as default in `Data.Aeson`. + As one side-effect, `decode` and `decode'` etc pair functions are operationally the same. + All variants use an intermediate `Value` in normal form. + + The lazier variant could had `Value` thunks inside `Array` (i.e. `Vector`), but the record had been value strict since version `0.4.0.0` (before that the lazy `Data.Map` was used as `Object`). + +* Move `Data.Aeson.Parser` module into separate [`attoparsec-aeson`](https://hackage.haskell.org/package/attoparsec-aeson) package, as these parsers are not used by `aeson` itself anymore. +* Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) package for parsing `time` types. These are slightly faster than previously used (copy of) `attoparsec-iso8601`. + Formats accepted is slightly changed: + - The space between time and timezone offset (in `UTCTime` and `ZonedTime`) is disallowed. ISO8601 explicitly forbids it. + - The timezone offsets can be in range -23:59..23:59. This is how Python, joda-time etc seems to do. (Previously the range was -12..+14) + +* Remove internal `Data.Aeson.Internal` and `Data.Aeson.Internal.Time` modules. Everything from the former is exported elsewhere (`Data.Aeson.Types`), the latter was truly internal. +* Remove `cffi` flag. Toggling the flag made `aeson` use a C implementation for string unescaping (used for `text <2` versions). + The new native Haskell implementation (introduced in version 2.0.3.0) is at least as fast. +* Drop instances for `Number` from `attoparsec` package. +* Improve `Arbitrary Value` instance. +* Add instances for `URI` from `network-uri`. +* add instances for `Down` from `Data.Ord`. +* Use `integer-conversion` for converting `Text` and `ByteString`s into `Integer`s. +* Bump lower bounds of non GHC-boot lib dependencies. + ### 2.1.2.1 * Support `th-abstraction-0.5` @@ -150,7 +255,7 @@ parseJSON = gParseJSON defaultOptions { rejectUnknownFields = True } ``` -* `FromJSON` instance of `Ratio a` now parses numbers in addtion to +* `FromJSON` instance of `Ratio a` now parses numbers in addition to standard `{numerator=..., denumerator=...}` encoding. Thanks to Aleksey Khudyakov. diff --git a/src-ffi/Data/Aeson/Parser/UnescapeFFI.hs b/src-ffi/Data/Aeson/Parser/UnescapeFFI.hs deleted file mode 100644 --- a/src-ffi/Data/Aeson/Parser/UnescapeFFI.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnliftedFFITypes #-} - -module Data.Aeson.Parser.UnescapeFFI - ( - unescapeText - ) where - -import Control.Exception (evaluate, throw, try) -import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) -import Data.ByteString as B -import Data.ByteString.Internal as B -import Data.Text.Encoding.Error (UnicodeException (..)) -import Data.Text.Internal (Text (..)) -import Data.Text.Internal.Private (runText) -import Data.Text.Unsafe (unsafeDupablePerformIO) -import Data.Word (Word8) -import Foreign.C.Types (CInt (..), CSize (..)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek) -import GHC.Base (MutableByteArray#) -import qualified Data.Text.Array as A - -foreign import ccall unsafe "_js_decode_string" c_js_decode - :: MutableByteArray# s -> Ptr CSize - -> Ptr Word8 -> Ptr Word8 -> IO CInt - -unescapeText' :: ByteString -> Text -#if MIN_VERSION_bytestring(0,11,0) -unescapeText' (BS fp len) = runText $ \done -> do - let off = 0 -#else -unescapeText' (PS fp off len) = runText $ \done -> do -#endif - let go dest = withForeignPtr fp $ \ptr -> - with (0::CSize) $ \destOffPtr -> do - let end = ptr `plusPtr` (off + len) - loop curPtr = do - res <- c_js_decode (A.maBA dest) destOffPtr curPtr end - case res of - 0 -> do - n <- peek destOffPtr - unsafeSTToIO (done dest (fromIntegral n)) - _ -> - throw (DecodeError desc Nothing) - loop (ptr `plusPtr` off) - (unsafeIOToST . go) =<< A.new len - where - desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" -{-# INLINE unescapeText' #-} - -unescapeText :: ByteString -> Either UnicodeException Text -unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText' -{-# INLINE unescapeText #-} diff --git a/src-pure/Data/Aeson/Parser/UnescapePure.hs b/src-pure/Data/Aeson/Parser/UnescapePure.hs deleted file mode 100644 --- a/src-pure/Data/Aeson/Parser/UnescapePure.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module Data.Aeson.Parser.UnescapePure - ( unescapeText - ) where - -import Control.Exception (throwIO, try) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Text.Encoding.Error (UnicodeException (..)) -import Data.Text.Unsafe (unsafeDupablePerformIO) -import Data.Word (Word32, Word8) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek) - -import qualified Data.Primitive as P -import qualified Data.Text.Array as T -import qualified Data.Text.Internal as T - -import Data.Aeson.Internal.ByteString - -#if !MIN_VERSION_text(2,0,0) -import Data.Word (Word16) -#endif - - -unescapeText :: ByteString -> Either UnicodeException Text -unescapeText = unsafeDupablePerformIO . try . unescapeTextIO - -throwDecodeError :: IO a -throwDecodeError = - let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" - in throwIO (DecodeError desc Nothing) - -------------------------------------------------------------------------------- --- unescapeTextIO -------------------------------------------------------------------------------- - --- This function is generated using staged-streams --- See: https://github.com/phadej/staged/blob/master/staged-streams-unicode/src/Unicode/JSON.hs --- --- Because @aeson@ better to not use template-haskell itself, --- we dump the splice and prettify it by hand a bit. --- -unescapeTextIO :: ByteString -> IO Text - -#if MIN_VERSION_text(2,0,0) - -unescapeTextIO bs = withBS bs $ \fptr len -> - withForeignPtr fptr $ \begin -> do - let end :: Ptr Word8 - end = plusPtr begin len - - arr <- P.newPrimArray len - - let write3bytes :: Int -> Word8 -> Word8 -> Word8 -> Ptr Word8 -> IO Text - write3bytes !out !b1 !b2 !b3 !inp = do - P.writePrimArray arr out b1 - write2bytes (out + 1) b2 b3 inp - - write2bytes :: Int -> Word8 -> Word8 -> Ptr Word8 -> IO Text - write2bytes !out !b1 !b2 !inp = do - P.writePrimArray arr out b1 - write1byte (out + 1) b2 inp - - write1byte :: Int -> Word8 -> Ptr Word8 -> IO Text - write1byte !out !b1 !inp = do - P.writePrimArray arr out b1 - state_start (out + 1) inp - - writeCodePoint :: Int -> Ptr Word8 -> Word32 -> IO Text - writeCodePoint !out !inp !acc - | acc <= 127 = do - P.writePrimArray arr out (fromIntegral acc :: Word8) - state_start (out + 1) (plusPtr inp 1) - - | acc <= 2047 = do - let b1 = fromIntegral (shiftR acc 6 .|. 192) :: Word8 - let b2 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 - P.writePrimArray arr out b1 - write1byte (out + 1) b2 (plusPtr inp 1) - - | acc <= 65535 = do - let b1 = fromIntegral (shiftR acc 12 .|. 224) :: Word8 - let b2 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 - let b3 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 - P.writePrimArray arr out b1 - write2bytes (out + 1) b2 b3 (plusPtr inp 1) - - | otherwise = do - let b1 = fromIntegral (shiftR acc 18 .|. 240) :: Word8 - let b2 = fromIntegral ((shiftR acc 12 .&. 63) .|. 128) :: Word8 - let b3 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 - let b4 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 - P.writePrimArray arr out b1 - write3bytes (out + 1) b2 b3 b4 (plusPtr inp 1) - - state_sudone :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text - state_sudone !out !inp !hi !lo - | 56320 <= lo, lo <= 57343 - = writeCodePoint out inp (65536 + (shiftL (hi - 55296) 10 .|. (lo - 56320))) - - | otherwise - = throwDecodeError - - state_su4 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text - state_su4 !out !inp !hi !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su3 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text - state_su3 !out !inp !hi !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su2 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text - state_su2 !out !inp !hi !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su1 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_su1 !out !inp !hi - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su :: Int -> Ptr Word8 -> Word32 -> IO Text - state_su !out !inp !hi - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 117 -> state_su1 out (plusPtr inp 1) hi - _ -> throwDecodeError - - state_ss :: Int -> Ptr Word8 -> Word32 -> IO Text - state_ss !out !inp !hi - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 92 -> state_su out (plusPtr inp 1) hi - _ -> throwDecodeError - - state_udone :: Int -> Ptr Word8 -> Word32 -> IO Text - state_udone !out !inp !acc - | acc < 55296 || acc > 57343 = - writeCodePoint out inp acc - - | acc < 56320 = - state_ss out (plusPtr inp 1) acc - - | otherwise = - throwDecodeError - - state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u4 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u3 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u3 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u2 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u1 :: Int -> Ptr Word8 -> IO Text - state_u1 !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_escape :: Int -> Ptr Word8 -> IO Text - state_escape !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 34 -> do - P.writePrimArray arr out 34 - state_start (out + 1) (plusPtr inp 1) - - 92 -> do - P.writePrimArray arr out 92 - state_start (out + 1) (plusPtr inp 1) - - 47 -> do - P.writePrimArray arr out 47 - state_start (out + 1) (plusPtr inp 1) - - 98 -> do - P.writePrimArray arr out 8 - state_start (out + 1) (plusPtr inp 1) - - 102 -> do - P.writePrimArray arr out 12 - state_start (out + 1) (plusPtr inp 1) - - 110 -> do - P.writePrimArray arr out 10 - state_start (out + 1) (plusPtr inp 1) - - 114 -> do - P.writePrimArray arr out 13 - state_start (out + 1) (plusPtr inp 1) - - 116 -> do - P.writePrimArray arr out 9 - state_start (out + 1) (plusPtr inp 1) - - 117 -> - state_u1 out (plusPtr inp 1) - - _ -> throwDecodeError - - state_input4c :: Int -> Ptr Word8 -> Word8 -> Word8 -> Word8 -> IO Text - state_input4c !out !inp !b1 !b2 !b3 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128 - , let acc = shiftL (fromIntegral (b1 .&. 7)) 18 - , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 12 - , let acc'' = acc' .|. shiftL (fromIntegral (b3 .&. 63)) 6 - , let acc''' = acc'' .|. fromIntegral (w8 .&. 63) :: Word32 - , acc''' >= 65536 && acc''' < 1114112 -> do - P.writePrimArray arr out b1 - write3bytes (out + 1) b2 b3 w8 (plusPtr inp 1) - - | otherwise -> - throwDecodeError - - state_input4b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text - state_input4b !out !inp !b1 !b2 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128 -> - state_input4c out (plusPtr inp 1) b1 b2 w8 - - | otherwise -> - throwDecodeError - - state_input4 :: Int -> Ptr Word8 -> Word8 -> IO Text - state_input4 !out !inp !b1 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128 -> - state_input4b out (plusPtr inp 1) b1 w8 - - | otherwise -> - throwDecodeError - - state_input3b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text - state_input3b !out !inp !b1 !b2 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128 - , let acc = shiftL (fromIntegral (b1 .&. 15)) 12 - , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 6 - , let acc'' = acc' .|. fromIntegral (w8 .&. 63) :: Word32 - , (acc'' >= 2048 && acc'' < 55296) || acc'' > 57343 -> do - P.writePrimArray arr out b1 - write2bytes (out + 1) b2 w8 (plusPtr inp 1) - - | otherwise -> - throwDecodeError - - state_input3 :: Int -> Ptr Word8 -> Word8 -> IO Text - state_input3 !out !inp !b1 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128 -> - state_input3b out (plusPtr inp 1) b1 w8 - - | otherwise -> - throwDecodeError - - state_input2 :: Int -> Ptr Word8 -> Word8 -> IO Text - state_input2 !out !inp !b1 - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 192) == 128, - let acc = shiftL (fromIntegral (b1 .&. 63)) 6 :: Word32 - acc' = acc .|. fromIntegral (w8 .&. 63) :: Word32 - , acc' >= 128 -> do - P.writePrimArray arr out b1 - write1byte (out + 1) w8 (plusPtr inp 1) - - | otherwise -> - throwDecodeError - - state_start :: Int -> Ptr Word8 -> IO Text - state_start !out !inp - | inp == end = do - P.shrinkMutablePrimArray arr out - frozenArr <- P.unsafeFreezePrimArray arr - return $ case frozenArr of - P.PrimArray ba -> T.Text (T.ByteArray ba) 0 out - - | otherwise = do - w8 <- peek inp - if | w8 == 92 -> state_escape out (plusPtr inp 1) - | w8 < 128 -> do - P.writePrimArray arr out w8 - state_start (out + 1) (plusPtr inp 1) - - | w8 < 192 -> throwDecodeError - | w8 < 224 -> state_input2 out (plusPtr inp 1) w8 - | w8 < 240 -> state_input3 out (plusPtr inp 1) w8 - | w8 < 248 -> state_input4 out (plusPtr inp 1) w8 - - | otherwise -> throwDecodeError - - -- start the state machine - state_start (0 :: Int) begin -#else - -unescapeTextIO bs = withBS bs $ \fptr len -> - withForeignPtr fptr $ \begin -> do - let end :: Ptr Word8 - end = plusPtr begin len - - arr <- P.newPrimArray len - - let writeLowSurrogate :: Int -> Word16 -> Ptr Word8 -> IO Text - writeLowSurrogate !out !w16 !inp = do - P.writePrimArray arr out w16 - state_start (out + 1) inp - - state_sudone :: Int -> Ptr Word8 -> Word32 -> IO Text - state_sudone !out !inp !lo - | 56320 <= lo, lo <= 57343 = do - P.writePrimArray arr out (fromIntegral lo) - state_start (out + 1) (plusPtr inp 1) - - | otherwise = - throwDecodeError - - state_su4 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_su4 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su3 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_su3 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> throwDecodeError - - state_su2 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_su2 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_su1 :: Int -> Ptr Word8 -> IO Text - state_su1 !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - -- high surrogate u - state_su :: Int -> Ptr Word8 -> IO Text - state_su !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 117 -> state_su1 out (plusPtr inp 1) - _ -> throwDecodeError - - -- high surrogate slash - state_ss :: Int -> Ptr Word8 -> IO Text - state_ss !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 92 -> state_su out (plusPtr inp 1) - _ -> throwDecodeError - - state_udone :: Int -> Ptr Word8 -> Word32 -> IO Text - state_udone !out !inp !acc - -- we know that codepoint in acc is in BMP - | acc < 55296 || acc > 57343 = do - P.writePrimArray arr out (fromIntegral acc) - state_start (out + 1) (plusPtr inp 1) - - -- hi surrogate, - -- we write it immediately (UTF16 as an output!) - | acc < 56320 = do - P.writePrimArray arr out (fromIntegral acc) - state_ss (out + 1) (plusPtr inp 1) - - | otherwise = - throwDecodeError - - state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u4 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u3 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u3 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_u2 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_u1 :: Int -> Ptr Word8 -> IO Text - state_u1 !out !inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | 48 <= w8, w8 <= 57 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) - | 65 <= w8, w8 <= 70 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) - | 97 <= w8, w8 <= 102 -> - state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) - | otherwise -> - throwDecodeError - - state_escape :: Int -> Ptr Word8 -> IO Text - state_escape out inp - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - case w8 of - 34 -> do - P.writePrimArray arr out 34 - state_start (out + 1) (plusPtr inp 1) - - 92 -> do - P.writePrimArray arr out 92 - state_start (out + 1) (plusPtr inp 1) - - 47 -> do - P.writePrimArray arr out 47 - state_start (out + 1) (plusPtr inp 1) - - 98 -> do - P.writePrimArray arr out 8 - state_start (out + 1) (plusPtr inp 1) - - 102 -> do - P.writePrimArray arr out 12 - state_start (out + 1) (plusPtr inp 1) - - 110 -> do - P.writePrimArray arr out 10 - state_start (out + 1) (plusPtr inp 1) - - 114 -> do - P.writePrimArray arr out 13 - state_start (out + 1) (plusPtr inp 1) - - 116 -> do - P.writePrimArray arr out 9 - state_start (out + 1) (plusPtr inp 1) - - 117 -> - state_u1 out (plusPtr inp 1) - - _ -> throwDecodeError - - state_input4c :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input4c !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 - , let acc' = acc .|. fromIntegral (w8 .&. 63) - , acc' >= 65536 && acc' < 1114112 -> - if {- -- | acc' < 65536 -> do - -- P.writePrimArray arr out (fromIntegral acc' :: Word16) - -- state_start (out + 1) (plusPtr inp 1) -} - | otherwise -> do - let u = acc' - 65536 - hi = fromIntegral (55296 + shiftR u 10) :: Word16 - lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 - P.writePrimArray arr out hi - writeLowSurrogate (out + 1) lo (plusPtr inp 1) - - | otherwise -> throwDecodeError - - state_input4b :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input4b !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 -> - state_input4c out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) - - | otherwise -> throwDecodeError - - state_input4 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input4 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 -> - state_input4b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 12) - - | otherwise -> throwDecodeError - - state_input3b :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input3b !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 - , let acc' = acc .|. fromIntegral (w8 .&. 63) - , (acc' >= 2048 && acc' < 55296) || acc' > 57343 -> - if | acc' < 65536 -> do - P.writePrimArray arr out (fromIntegral acc') - state_start (out + 1) (plusPtr inp 1) - - | otherwise -> do - let u = acc' - 65536 - hi = fromIntegral (55296 + shiftR u 10) :: Word16 - lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 - P.writePrimArray arr out hi - writeLowSurrogate (out + 1) lo (plusPtr inp 1) - - | otherwise -> throwDecodeError - - state_input3 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input3 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 -> - state_input3b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) - | otherwise -> throwDecodeError - - state_input2 :: Int -> Ptr Word8 -> Word32 -> IO Text - state_input2 !out !inp !acc - | inp == end = throwDecodeError - | otherwise = do - w8 <- peek inp - if | (w8 .&. 0xc0) == 0x80 - , let acc' = acc .|. fromIntegral (w8 .&. 63) - , acc' >= 0x80 -> do - P.writePrimArray arr out (fromIntegral acc' :: Word16) - state_start (out + 1) (plusPtr inp 1) - - | otherwise -> throwDecodeError - - state_start :: Int -> Ptr Word8 -> IO Text - state_start !out !inp - | inp == end = do - P.shrinkMutablePrimArray arr out - frozenArr <- P.unsafeFreezePrimArray arr - return $ case frozenArr of - P.PrimArray ba -> T.Text (T.Array ba) 0 out - - | otherwise = do - w8 <- peek inp - if | w8 == 92 -> state_escape out (plusPtr inp 1) - | w8 < 0x80 -> do - P.writePrimArray arr out (fromIntegral w8 :: Word16) - state_start (out + 1) (plusPtr inp 1) - - | w8 < 0xc0 -> throwDecodeError - | w8 < 224 -> state_input2 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 63)) 6) - | w8 < 240 -> state_input3 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 15)) 12) - | w8 < 248 -> state_input4 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 7)) 18) - | otherwise -> throwDecodeError - - -- start the state machine - state_start (0 :: Int) begin - -#endif diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module: Data.Aeson @@ -56,10 +55,14 @@ , eitherDecodeFileStrict , eitherDecodeStrict' , eitherDecodeFileStrict' + -- ** Variants for strict text + , decodeStrictText + , eitherDecodeStrictText -- ** Exception throwing variants , AesonException (..) , throwDecode , throwDecodeStrict + , throwDecodeStrictText , throwDecode' , throwDecodeStrict' -- * Core JSON types @@ -77,6 +80,7 @@ , fromJSON , ToJSON(..) , KeyValue(..) + , KeyValueOmit(..) , () , JSONPath -- ** Keys for maps @@ -92,14 +96,18 @@ -- ** Liftings to unary and binary type constructors , FromJSON1(..) , parseJSON1 + , omittedField1 , FromJSON2(..) , parseJSON2 + , omittedField2 , ToJSON1(..) , toJSON1 , toEncoding1 + , omitField1 , ToJSON2(..) , toJSON2 , toEncoding2 + , omitField2 -- ** Generic JSON classes and options , GFromJSON , FromArgs @@ -124,6 +132,7 @@ , constructorTagModifier , allNullaryToStringTag , omitNothingFields + , allowOmittedFields , sumEncoding , unwrapUnaryRecords , tagSingleConstructors @@ -152,24 +161,21 @@ , (.:?) , (.:!) , (.!=) + , (.:?=) + , (.:!=) , object -- * Parsing - , json - , json' , parseIndexedJSON ) where -import Prelude.Compat - -import Control.Exception (Exception (..)) import Control.Monad.Catch (MonadThrow (..)) -import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON) +import Data.Aeson.Types.FromJSON (parseIndexedJSON) import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json') import Data.Aeson.Types -import Data.Aeson.Types.Internal (formatError) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Aeson.Decoding (decode, eitherDecode, throwDecode, decodeStrict, eitherDecodeStrict, throwDecodeStrict) +import Data.Aeson.Decoding (decodeStrictText, eitherDecodeStrictText, throwDecodeStrictText) -- $setup -- >>> :set -XOverloadedStrings @@ -184,32 +190,6 @@ encodeFile :: (ToJSON a) => FilePath -> a -> IO () encodeFile fp = L.writeFile fp . encode --- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decode :: (FromJSON a) => L.ByteString -> Maybe a -decode = decodeWith jsonEOF fromJSON -{-# INLINE decode #-} - --- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a -decodeStrict = decodeStrictWith jsonEOF fromJSON -{-# INLINE decodeStrict #-} - -- | Efficiently deserialize a JSON value from a file. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. @@ -219,6 +199,8 @@ -- -- This function parses immediately, but defers conversion. See -- 'json' for details. +-- +-- Throws an 'Exception' when the file is missing. decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) decodeFileStrict = fmap decodeStrict . B.readFile @@ -226,134 +208,83 @@ -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. +-- Since @2.2.0.0@ an alias for 'decode'. -- --- This function parses and performs conversion immediately. See --- 'json'' for details. decode' :: (FromJSON a) => L.ByteString -> Maybe a -decode' = decodeWith jsonEOF' fromJSON +decode' = decode {-# INLINE decode' #-} -- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. +-- Since @2.2.0.0@ an alias for 'decodeStrict'. -- --- This function parses and performs conversion immediately. See --- 'json'' for details. decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a -decodeStrict' = decodeStrictWith jsonEOF' fromJSON +decodeStrict' = decodeStrict {-# INLINE decodeStrict' #-} -- | Efficiently deserialize a JSON value from a file. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input file's content must consist solely of a JSON document, --- with no trailing data except for whitespace. +-- Throws an 'Exception' when the file is missing. -- --- This function parses and performs conversion immediately. See --- 'json'' for details. +-- Since @2.2.0.0@ an alias for 'decodeFileStrict'. decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a) -decodeFileStrict' = fmap decodeStrict' . B.readFile - -eitherFormatError :: Either (JSONPath, String) a -> Either String a -eitherFormatError = either (Left . uncurry formatError) Right -{-# INLINE eitherFormatError #-} - --- | Like 'decode' but returns an error message when decoding fails. -eitherDecode :: (FromJSON a) => L.ByteString -> Either String a -eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON -{-# INLINE eitherDecode #-} - --- | Like 'decodeStrict' but returns an error message when decoding fails. -eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a -eitherDecodeStrict = - eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON -{-# INLINE eitherDecodeStrict #-} +decodeFileStrict' = decodeFileStrict -- | Like 'decodeFileStrict' but returns an error message when decoding fails. +-- +-- Throws an 'Exception' when the file is missing. eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict = fmap eitherDecodeStrict . B.readFile {-# INLINE eitherDecodeFileStrict #-} -- | Like 'decode'' but returns an error message when decoding fails. +-- +-- Since @2.2.0.0@ an alias for 'eitherDecode'. eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a -eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON +eitherDecode' = eitherDecode {-# INLINE eitherDecode' #-} -- | Like 'decodeStrict'' but returns an error message when decoding fails. +-- +-- Since @2.2.0.0@ an alias for 'eitherDecodeStrict'. eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a -eitherDecodeStrict' = - eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON +eitherDecodeStrict' = eitherDecodeStrict {-# INLINE eitherDecodeStrict' #-} -- | Like 'decodeFileStrict'' but returns an error message when decoding fails. -eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) -eitherDecodeFileStrict' = - fmap eitherDecodeStrict' . B.readFile -{-# INLINE eitherDecodeFileStrict' #-} - -throwFormatError :: MonadThrow m => Either (JSONPath, String) a -> m a -throwFormatError = either (throwM . AesonException . uncurry formatError) return -{-# INLINE throwFormatError #-} - --- | Like 'decode' but throws an 'AesonException' when decoding fails. -- --- >>> throwDecode "42" :: Maybe Int --- Just 42 --- --- >>> throwDecode "42" :: IO Int --- 42 --- --- >>> throwDecode "true" :: IO Int --- ...Exception: AesonException... --- --- @since 2.1.2.0 --- -throwDecode :: forall a m. (FromJSON a, MonadThrow m) => L.ByteString -> m a -throwDecode = throwFormatError . eitherDecodeWith jsonEOF ifromJSON -{-# INLINE throwDecode #-} - --- | Like 'decodeStrict' but throws an 'AesonException' when decoding fails. --- --- @since 2.1.2.0 +-- Throws an 'Exception' when the file is missing. -- -throwDecodeStrict :: forall a m. (FromJSON a, MonadThrow m) => B.ByteString -> m a -throwDecodeStrict = - throwFormatError . eitherDecodeStrictWith jsonEOF ifromJSON -{-# INLINE throwDecodeStrict #-} +-- Since @2.2.0.0@ an alias for 'eitherDecodeFileStrict'. +eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) +eitherDecodeFileStrict' = eitherDecodeFileStrict +{-# INLINE eitherDecodeFileStrict' #-} -- | Like 'decode'' but throws an 'AesonException' when decoding fails. -- +-- Since @2.2.0.0@ an alias for 'throwDecode'. +-- -- @since 2.1.2.0 -- throwDecode' :: forall a m. (FromJSON a, MonadThrow m) => L.ByteString -> m a -throwDecode' = throwFormatError . eitherDecodeWith jsonEOF' ifromJSON +throwDecode' = throwDecode {-# INLINE throwDecode' #-} -- | Like 'decodeStrict'' but throws an 'AesonException' when decoding fails. -- +-- Since @2.2.0.0@ an alias for 'throwDecodeStrict'. +-- -- @since 2.1.2.0 -- throwDecodeStrict' :: forall a m. (FromJSON a, MonadThrow m) => B.ByteString -> m a -throwDecodeStrict' = - throwFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON +throwDecodeStrict' = throwDecodeStrict {-# INLINE throwDecodeStrict' #-} --- | Exception thrown by 'throwDecode' and variants. --- --- @since 2.1.2.0 -newtype AesonException = AesonException String - deriving (Show) - -instance Exception AesonException where - displayException (AesonException str) = "aeson: " ++ str - -- $use -- -- This section contains basic information on the different ways to @@ -362,7 +293,7 @@ -- -- The most common way to use the library is to define a data type, -- corresponding to some JSON data you want to work with, and then --- write either a 'FromJSON' instance, a to 'ToJSON' instance, or both +-- write either a 'FromJSON' instance, a 'ToJSON' instance, or both -- for that type. -- -- For example, given this JSON data: @@ -633,5 +564,5 @@ -- -- For more information, see -- , --- and +-- and -- (where the relevant parsers are defined). diff --git a/src/Data/Aeson/Decoding.hs b/src/Data/Aeson/Decoding.hs --- a/src/Data/Aeson/Decoding.hs +++ b/src/Data/Aeson/Decoding.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Convertion to and from @aeson@ 'A.Value'. +-- | Conversion to and from @aeson@ 'A.Value'. +-- module Data.Aeson.Decoding ( decode, eitherDecode, @@ -9,24 +9,26 @@ decodeStrict, eitherDecodeStrict, throwDecodeStrict, + decodeStrictText, + eitherDecodeStrictText, + throwDecodeStrictText, toEitherValue, + unescapeText, ) where import Control.Monad.Catch (MonadThrow (..)) -import Data.Aeson.Key (Key) -import Data.Aeson.Types.Internal (formatError) -import Data.Scientific (Scientific) +import Data.Aeson.Types.Internal (AesonException (..), formatError) -import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T -import Data.Aeson (AesonException (..)) import Data.Aeson.Decoding.ByteString import Data.Aeson.Decoding.ByteString.Lazy -import Data.Aeson.Decoding.Tokens +import Data.Aeson.Decoding.Text +import Data.Aeson.Decoding.Conversion +import Data.Aeson.Internal.Unescape (unescapeText) ------------------------------------------------------------------------------- -- Decoding: strict bytestring @@ -35,7 +37,7 @@ -- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -decodeStrict :: (A.FromJSON a) => B.ByteString -> Maybe a +decodeStrict :: (A.FromJSON a) => BS.ByteString -> Maybe a decodeStrict bs = unResult (toResultValue (bsToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> Just x @@ -43,7 +45,7 @@ A.IError _ _ -> Nothing -- | Like 'decodeStrict' but returns an error message when decoding fails. -eitherDecodeStrict :: (A.FromJSON a) => B.ByteString -> Either String a +eitherDecodeStrict :: (A.FromJSON a) => BS.ByteString -> Either String a eitherDecodeStrict bs = unResult (toResultValue (bsToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> Right x @@ -51,7 +53,7 @@ A.IError path msg -> Left $ formatError path msg -- | Like 'decodeStrict' but throws an 'AesonException' when decoding fails. -throwDecodeStrict :: forall a m. (A.FromJSON a, MonadThrow m) => B.ByteString -> m a +throwDecodeStrict :: forall a m. (A.FromJSON a, MonadThrow m) => BS.ByteString -> m a throwDecodeStrict bs = unResult (toResultValue (bsToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> pure x @@ -62,18 +64,18 @@ -- Decoding: lazy bytestring ------------------------------------------------------------------------------- --- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. +-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -decode :: (A.FromJSON a) => L.ByteString -> Maybe a +decode :: (A.FromJSON a) => LBS.ByteString -> Maybe a decode bs = unResult (toResultValue (lbsToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> Just x | otherwise -> Nothing A.IError _ _ -> Nothing --- | Like 'decodeStrict' but returns an error message when decoding fails. -eitherDecode :: (A.FromJSON a) => L.ByteString -> Either String a +-- | Like 'decode' but returns an error message when decoding fails. +eitherDecode :: (A.FromJSON a) => LBS.ByteString -> Either String a eitherDecode bs = unResult (toResultValue (lbsToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> Right x @@ -81,7 +83,9 @@ A.IError path msg -> Left $ formatError path msg -- | Like 'decode' but throws an 'AesonException' when decoding fails. -throwDecode :: forall a m. (A.FromJSON a, MonadThrow m) => L.ByteString -> m a +-- +-- 'throwDecode' is in @aeson@ since 2.1.2.0, but this variant is added later. +throwDecode :: forall a m. (A.FromJSON a, MonadThrow m) => LBS.ByteString -> m a throwDecode bs = unResult (toResultValue (lbsToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> pure x @@ -89,63 +93,37 @@ A.IError path msg -> throwM $ AesonException $ formatError path msg ------------------------------------------------------------------------------- --- Conversions +-- Decoding: strict text ------------------------------------------------------------------------------- -bsSpace :: B.ByteString -> Bool -bsSpace = B.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) - -lbsSpace :: L.ByteString -> Bool -lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) - --- | Convert 'Tokens' to 'A.Value'. -toEitherValue - :: Tokens k e -- ^ tokens - -> Either e (A.Value, k) -- ^ either token error or value and leftover. -toEitherValue t = unResult (toResultValue t) Left $ \v k -> Right (v, k) - -toResultValue - :: Tokens k e -- ^ tokens - -> Result e k A.Value -- ^ either token error or value and leftover. -toResultValue t0 = Result (go t0) where - go :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r - go (TkLit l k) _ f = f (lit l) k - go (TkText t k) _ f = f (A.String t) k - go (TkNumber n k) _ f = f (A.Number (num n)) k - go (TkArrayOpen arr) g f = goA 0 id arr g $ \n xs k -> f (A.Array (V.fromListN n xs)) k - go (TkRecordOpen rec) g f = goR [] rec g $ \xs k -> f (A.Object (KM.fromList xs)) k - go (TkErr e) g _ = g e - - lit :: Lit -> A.Value - lit LitNull = A.Null - lit LitTrue = A.Bool True - lit LitFalse = A.Bool False - - num :: Number -> Scientific - num (NumInteger n) = fromInteger n - num (NumDecimal s) = s - num (NumScientific s) = s - - goA :: Int -- size accumulator - -> ([A.Value] -> [A.Value]) -- dlist accumulator - -> TkArray k e -- array tokens - -> (e -> r) -- error continuation - -> (Int -> [A.Value] -> k -> r) -- success continuation - -> r - goA !n !acc (TkItem toks) g f = go toks g $ \v k -> goA (succ n) (acc . (v :)) k g f - goA !n !acc (TkArrayEnd k) _ f = f n (acc []) k - goA !_ !_ (TkArrayErr e) g _ = g e +-- | Efficiently deserialize a JSON value from a strict 'T.Text'. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- @since 2.2.1.0 +decodeStrictText :: (A.FromJSON a) => T.Text -> Maybe a +decodeStrictText bs = unResult (toResultValue (textToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of + A.ISuccess x + | textSpace bs' -> Just x + | otherwise -> Nothing + A.IError _ _ -> Nothing - -- we accumulate keys in reverse order - -- then the first duplicate key in objects wins (as KM.fromList picks last). - goR :: [(Key, A.Value)] - -> TkRecord k e - -> (e -> r) - -> ([(Key, A.Value)] -> k -> r) - -> r - goR !acc (TkPair t toks) g f = go toks g $ \v k -> goR ((t , v) : acc) k g f - goR !acc (TkRecordEnd k) _ f = f acc k - goR !_ (TkRecordErr e) g _ = g e +-- | Like 'decodeStrictText' but returns an error message when decoding fails. +-- +-- @since 2.2.1.0 +eitherDecodeStrictText :: (A.FromJSON a) => T.Text -> Either String a +eitherDecodeStrictText bs = unResult (toResultValue (textToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of + A.ISuccess x + | textSpace bs' -> Right x + | otherwise -> Left "Trailing garbage" + A.IError path msg -> Left $ formatError path msg -newtype Result e k a = Result - { unResult :: forall r. (e -> r) -> (a -> k -> r) -> r } +-- | Like 'decodeStrictText' but throws an 'AesonException' when decoding fails. +-- +-- @since 2.2.1.0 +throwDecodeStrictText :: forall a m. (A.FromJSON a, MonadThrow m) => T.Text -> m a +throwDecodeStrictText bs = unResult (toResultValue (textToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of + A.ISuccess x + | textSpace bs' -> pure x + | otherwise -> throwM $ AesonException "Trailing garbage" + A.IError path msg -> throwM $ AesonException $ formatError path msg diff --git a/src/Data/Aeson/Decoding/ByteString.hs b/src/Data/Aeson/Decoding/ByteString.hs --- a/src/Data/Aeson/Decoding/ByteString.hs +++ b/src/Data/Aeson/Decoding/ByteString.hs @@ -10,6 +10,7 @@ import Data.ByteString (ByteString) import Data.Char (chr) +import Data.Integer.Conversion (byteStringToInteger) import Data.Text (Text) import Data.Word (Word8) @@ -17,13 +18,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS.Unsafe import qualified Data.Scientific as Sci +import qualified Data.Word8.Patterns as W8 import Data.Aeson.Decoding.Internal import Data.Aeson.Decoding.Tokens -import Data.Aeson.Internal.Integer import Data.Aeson.Internal.Text (unsafeDecodeASCII) -import Data.Aeson.Internal.Word8 -import Data.Aeson.Parser.Unescape (unescapeText) +import Data.Aeson.Internal.Unescape (unescapeText) -- | Lex (and parse) strict 'ByteString' into 'Tokens' stream. -- @@ -42,17 +42,17 @@ -> ByteString -- whole input, needed for number parsing -> (ByteString -> k) -- continuation -> Tokens k String - tokenCase W8_OPEN_CURLY !bs !_ k = TkRecordOpen (goR bs k) - tokenCase W8_OPEN_SQUARE bs _ k = TkArrayOpen (goA bs k) - tokenCase W8_DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs - tokenCase W8_MINUS bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase W8.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W8.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W8.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W8.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs tokenCase w _ wbs k - | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs - tokenCase W8_n bs _ k + | W8.DIGIT_0 <= w, w <= W8.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W8.LOWER_N bs _ k | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) - tokenCase W8_t bs _ k + tokenCase W8.LOWER_T bs _ k | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) - tokenCase W8_f bs _ k + tokenCase W8.LOWER_F bs _ k | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" @@ -60,33 +60,33 @@ goA :: Parser TkArray k goA (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF "JSON value or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k goA1 :: Parser TkArray k goA1 (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF ", or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) - Just (W8_COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k _ -> tkErrBS bs ", or ]" -- Record goR :: Parser TkRecord k goR (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF "record key literal or }" - Just (W8_DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just (W8.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } Just _ -> tkErrBS bs "record key literal or }" -- after record pair, expecting ," or } goR1 :: Parser TkRecord k goR1 (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErr "Unexpected end-of-input, expecting , or }" - Just (W8_COMMA, !bs1) -> case BS.uncons (skipSpace bs1) of + Just (W8.COMMA, !bs1) -> case BS.uncons (skipSpace bs1) of Nothing -> tkErrEOF "key literal" - Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just (W8.DOUBLE_QUOTE, !bs2) -> goRK bs2 k Just _ -> tkErrBS bs "key literal" - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" -- key of record (after double quote) @@ -97,7 +97,7 @@ goRK' :: Text -> Parser TkRecord k goRK' t (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF ":" - Just (W8_COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k + Just (W8.COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k Just _ -> tkErrBS bs ":" stripPrefix :: ByteString -> Int -> ByteString -> Maybe ByteString @@ -153,7 +153,9 @@ Right t -> ok t (BS.drop (n + 1) bs0) Left e -> err (show e) Just (92, bs') -> goSlash (n + 1) bs' - Just (_, bs') -> goEsc (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' goSlash :: Int -> ByteString -> r goSlash !n !bs = case BS.uncons bs of @@ -161,7 +163,7 @@ Just (_, bs') -> goEsc (n + 1) bs' errEnd = err "Unexpected end-of-input while parsing string literal" - errCC = err "Unespected control character while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" ------------------------------------------------------------------------------- -- Number @@ -187,46 +189,46 @@ state_start !bs = case BS.uncons bs of Nothing -> errEnd Just (w8, bs') - | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs' - | W8_0 == w8 -> state_after0 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 < w8, w8 <= W8.DIGIT_9 -> state_i1 1 bs' + | W8.DIGIT_0 == w8 -> state_after0 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" state_after0 :: ByteString -> r state_after0 !bs = case BS.uncons bs of Nothing -> kont (NumInteger 0) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> err "Number literal with leading zero" - | W8_DOT == w8 -> go_dec 0 bs' - | W8_e == w8 || W8_E == w8 -> go_sci 0 0 bs' - | otherwise -> kont (NumInteger 0) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> err "Number literal with leading zero" + | W8.PERIOD == w8 -> go_dec 0 bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs state_i1 :: Int -> ByteString -> r state_i1 !n !bs = case BS.uncons bs of Nothing -> kont (NumInteger int) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_i1 (n + 1) bs' - | W8_DOT == w8 -> go_dec int bs' - | W8_e == w8 || W8_E == w8 -> go_sci int 0 bs' - | otherwise -> kont (NumInteger int) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_i1 (n + 1) bs' + | W8.PERIOD == w8 -> go_dec int bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs where - int = bsToInteger (BS.Unsafe.unsafeTake n bs0) + int = byteStringToInteger (BS.Unsafe.unsafeTake n bs0) go_dec :: Integer -> ByteString -> r go_dec !int !bs1 = case BS.uncons bs1 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec 1 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec 1 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" where state_dec :: Int -> ByteString -> r state_dec !n !bs = case BS.uncons bs of Nothing -> kont (NumDecimal dec) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec (n + 1) bs' - | W8_e == w8 || W8_E == w8 -> go_sci coef (negate n) bs' - | otherwise -> kont (NumDecimal dec) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec (n + 1) bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs where - frac = bsToInteger (BS.Unsafe.unsafeTake n bs1) + frac = byteStringToInteger (BS.Unsafe.unsafeTake n bs1) coef = int * 10 ^ n + frac dec = Sci.scientific coef (negate n) @@ -234,37 +236,37 @@ go_sci !coef !exp10 !bs2 = case BS.uncons bs2 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 1 bs' - | W8_PLUS == w8 -> case BS.uncons bs' of - Nothing -> errEnd + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W8.PLUS == w8 -> case BS.uncons bs' of + Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_pos coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | W8_MINUS == w8 -> case BS.uncons bs' of + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | W8.HYPHEN == w8 -> case BS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_neg coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | otherwise -> errUnx w8 + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | otherwise -> errUnx w8 go_sci_pos :: Integer -> Int -> ByteString -> Int -> ByteString -> r go_sci_pos !coef !exp10 !bs2 !n !bs = case BS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' - | otherwise -> kont (NumScientific sci) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs where - exp10' = fromInteger (bsToInteger (BS.Unsafe.unsafeTake n bs2)) + exp10' = fromInteger (byteStringToInteger (BS.Unsafe.unsafeTake n bs2)) sci = Sci.scientific coef (exp10 + exp10') go_sci_neg :: Integer -> Int -> ByteString -> Int -> ByteString -> r go_sci_neg !coef !exp10 !bs2 !n !bs = case BS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where - exp10' = fromInteger (bsToInteger (BS.Unsafe.unsafeTake n bs2)) + exp10' = fromInteger (byteStringToInteger (BS.Unsafe.unsafeTake n bs2)) sci = Sci.scientific coef (exp10 - exp10') errEnd = err "Unexpected end-of-input while parsing number literal" diff --git a/src/Data/Aeson/Decoding/ByteString/Lazy.hs b/src/Data/Aeson/Decoding/ByteString/Lazy.hs --- a/src/Data/Aeson/Decoding/ByteString/Lazy.hs +++ b/src/Data/Aeson/Decoding/ByteString/Lazy.hs @@ -10,6 +10,7 @@ import Data.ByteString.Lazy (ByteString) import Data.Char (chr) +import Data.Integer.Conversion (byteStringToInteger) import Data.Text (Text) import Data.Word (Word8) @@ -17,13 +18,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Scientific as Sci +import qualified Data.Word8.Patterns as W8 import Data.Aeson.Decoding.Internal import Data.Aeson.Decoding.Tokens -import Data.Aeson.Internal.Integer import Data.Aeson.Internal.Text (unsafeDecodeASCII) -import Data.Aeson.Internal.Word8 -import Data.Aeson.Parser.Unescape (unescapeText) +import Data.Aeson.Internal.Unescape (unescapeText) -- | Lex (and parse) lazy 'ByteString' into 'Tokens' stream. -- @@ -42,17 +42,17 @@ -> ByteString -- whole input, needed for number parsing -> (ByteString -> k) -- continuation -> Tokens k String - tokenCase W8_OPEN_CURLY !bs !_ k = TkRecordOpen (goR bs k) - tokenCase W8_OPEN_SQUARE bs _ k = TkArrayOpen (goA bs k) - tokenCase W8_DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs - tokenCase W8_MINUS bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase W8.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W8.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W8.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W8.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs tokenCase w _ wbs k - | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs - tokenCase W8_n bs _ k + | W8.DIGIT_0 <= w, w <= W8.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W8.LOWER_N bs _ k | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) - tokenCase W8_t bs _ k + tokenCase W8.LOWER_T bs _ k | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) - tokenCase W8_f bs _ k + tokenCase W8.LOWER_F bs _ k | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" @@ -60,33 +60,33 @@ goA :: Parser TkArray k goA (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF "JSON value or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k goA1 :: Parser TkArray k goA1 (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF ", or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) - Just (W8_COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k _ -> tkErrBS bs ", or ]" -- Record goR :: Parser TkRecord k goR (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF "record key literal or }" - Just (W8_DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just (W8.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } Just _ -> tkErrBS bs "record key literal or }" -- after record pair, expecting ," or } goR1 :: Parser TkRecord k goR1 (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErr "Unexpected end-of-input, expecting , or }" - Just (W8_COMMA, !bs1) -> case LBS.uncons (skipSpace bs1) of + Just (W8.COMMA, !bs1) -> case LBS.uncons (skipSpace bs1) of Nothing -> tkErrEOF "key literal" - Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just (W8.DOUBLE_QUOTE, !bs2) -> goRK bs2 k Just _ -> tkErrBS bs "key literal" - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" -- key of record (after double quote) @@ -97,7 +97,7 @@ goRK' :: Text -> Parser TkRecord k goRK' t (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF ":" - Just (W8_COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k + Just (W8.COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k Just _ -> tkErrBS bs ":" stripPrefix :: ByteString -> Int -> ByteString -> Maybe ByteString @@ -159,7 +159,9 @@ Right t -> ok t (lbsDrop (n + 1) bs0) Left e -> err (show e) Just (92, bs') -> goSlash (n + 1) bs' - Just (_, bs') -> goEsc (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' goSlash :: Int -> ByteString -> r goSlash !n !bs = case LBS.uncons bs of @@ -167,7 +169,7 @@ Just (_, bs') -> goEsc (n + 1) bs' errEnd = err "Unexpected end-of-input while parsing string literal" - errCC = err "Unespected control character while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" ------------------------------------------------------------------------------- -- Number @@ -193,46 +195,46 @@ state_start !bs = case LBS.uncons bs of Nothing -> errEnd Just (w8, bs') - | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs' - | W8_0 == w8 -> state_after0 bs' + | W8.DIGIT_0 < w8, w8 <= W8.DIGIT_9 -> state_i1 1 bs' + | W8.DIGIT_0 == w8 -> state_after0 bs' | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" state_after0 :: ByteString -> r state_after0 !bs = case LBS.uncons bs of Nothing -> kont (NumInteger 0) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> err "Number literal with leading zero" - | W8_DOT == w8 -> go_dec 0 bs' - | W8_e == w8 || W8_E == w8 -> go_sci 0 0 bs' - | otherwise -> kont (NumInteger 0) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> err "Number literal with leading zero" + | W8.PERIOD == w8 -> go_dec 0 bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs state_i1 :: Int -> ByteString -> r state_i1 !n !bs = case LBS.uncons bs of Nothing -> kont (NumInteger int) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_i1 (n + 1) bs' - | W8_DOT == w8 -> go_dec int bs' - | W8_e == w8 || W8_E == w8 -> go_sci int 0 bs' - | otherwise -> kont (NumInteger int) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_i1 (n + 1) bs' + | W8.PERIOD == w8 -> go_dec int bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs where - int = bsToInteger (lbsTake n bs0) + int = byteStringToInteger (lbsTake n bs0) go_dec :: Integer -> ByteString -> r go_dec !int !bs1 = case LBS.uncons bs1 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec 1 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec 1 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" where state_dec :: Int -> ByteString -> r state_dec !n !bs = case LBS.uncons bs of Nothing -> kont (NumDecimal dec) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec (n + 1) bs' - | W8_e == w8 || W8_E == w8 -> go_sci coef (negate n) bs' - | otherwise -> kont (NumDecimal dec) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec (n + 1) bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs where - frac = bsToInteger (lbsTake n bs1) + frac = byteStringToInteger (lbsTake n bs1) coef = int * 10 ^ n + frac dec = Sci.scientific coef (negate n) @@ -240,16 +242,16 @@ go_sci !coef !exp10 !bs2 = case LBS.uncons bs2 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 1 bs' - | W8_PLUS == w8 -> case LBS.uncons bs' of + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W8.PLUS == w8 -> case LBS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' | otherwise -> errUnx w8' - | W8_MINUS == w8 -> case LBS.uncons bs' of + | W8.HYPHEN == w8 -> case LBS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' | otherwise -> errUnx w8' | otherwise -> errUnx w8 @@ -257,20 +259,20 @@ go_sci_pos !coef !exp10 !bs2 !n !bs = case LBS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where - exp10' = fromInteger (bsToInteger (lbsTake n bs2)) + exp10' = fromInteger (byteStringToInteger (lbsTake n bs2)) sci = Sci.scientific coef (exp10 + exp10') go_sci_neg :: Integer -> Int -> ByteString -> Int -> ByteString -> r go_sci_neg !coef !exp10 !bs2 !n !bs = case LBS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where - exp10' = fromInteger (bsToInteger (lbsTake n bs2)) + exp10' = fromInteger (byteStringToInteger (lbsTake n bs2)) sci = Sci.scientific coef (exp10 - exp10') errEnd = err "Unexpected end-of-input while parsing number literal" diff --git a/src/Data/Aeson/Decoding/Conversion.hs b/src/Data/Aeson/Decoding/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Decoding/Conversion.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +module Data.Aeson.Decoding.Conversion ( + bsSpace, + lbsSpace, + textSpace, + ltextSpace, + toEitherValue, + toResultValue, + Result (..), +) where + +import Data.Aeson.Key (Key) +import Data.Scientific (Scientific) + +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Aeson.Types.Internal as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +import Data.Aeson.Decoding.Tokens + +bsSpace :: B.ByteString -> Bool +bsSpace = B.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) + +lbsSpace :: L.ByteString -> Bool +lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) + +textSpace :: T.Text -> Bool +textSpace = T.all (\c -> c == ' ' || c == '\r' || c == '\n' || c == '\t') + +ltextSpace :: LT.Text -> Bool +ltextSpace = LT.all (\c -> c == ' ' || c == '\r' || c == '\n' || c == '\t') + +-- | Convert 'Tokens' to 'A.Value'. +-- +-- The resulting value will be in normal form if its forced. +-- In other words, there shouldn't be thunks inside. +-- +toEitherValue + :: Tokens k e -- ^ tokens + -> Either e (A.Value, k) -- ^ either token error or value and leftover. +toEitherValue t = unResult (toResultValue t) Left $ \v k -> Right (v, k) + +toResultValue + :: Tokens k e -- ^ tokens + -> Result e k A.Value -- ^ either token error or value and leftover. +toResultValue t0 = Result (convert t0) + +convert :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r +convert (TkLit l k) _ f = f (lit l) k where + lit :: Lit -> A.Value + lit LitNull = A.Null + lit LitTrue = A.Bool True + lit LitFalse = A.Bool False +convert (TkText t k) _ f = f (A.String t) k +convert (TkNumber n k) _ f = f (A.Number (num n)) k where + num :: Number -> Scientific + num (NumInteger m) = fromInteger m + num (NumDecimal s) = s + num (NumScientific s) = s +convert (TkArrayOpen arr) g f = convertA arr g $ \xs k -> f (A.Array xs) k +convert (TkRecordOpen rec) g f = convertR rec g $ \xs k -> f (A.Object xs) k +convert (TkErr e) g _ = g e + +convertA :: TkArray k e -> (e -> r) -> (A.Array -> k -> r) -> r +convertA tka err kont = goA 0 id tka err $ \n xs -> kont (V.fromListN n xs) where + goA :: Int -- size accumulator + -> ([A.Value] -> [A.Value]) -- dlist accumulator + -> TkArray k e -- array tokens + -> (e -> r) -- error continuation + -> (Int -> [A.Value] -> k -> r) -- success continuation + -> r + goA !n !acc (TkItem toks) g f = convert toks g $ \ !v k -> goA (succ n) (acc . (v :)) k g f + goA !n !acc (TkArrayEnd k) _ f = f n (acc []) k + goA !_ !_ (TkArrayErr e) g _ = g e + +convertR :: TkRecord k e -> (e -> r) -> (A.Object -> k -> r) -> r +convertR tkr err kont = goR [] tkr err $ kont . KM.fromList where + -- we accumulate keys in reverse order + -- then the first duplicate key in objects wins (as KM.fromList picks last). + goR :: [(Key, A.Value)] + -> TkRecord k e + -> (e -> r) + -> ([(Key, A.Value)] -> k -> r) + -> r + -- here we don't strictly need bang on !v as KM is a Strict (in values) map. + -- but we force the value sooner. + goR !acc (TkPair t toks) g f = convert toks g $ \ !v k -> goR ((t , v) : acc) k g f + goR !acc (TkRecordEnd k) _ f = f acc k + goR !_ (TkRecordErr e) g _ = g e + +newtype Result e k a = Result + { unResult :: forall r. (e -> r) -> (a -> k -> r) -> r } diff --git a/src/Data/Aeson/Decoding/Text.hs b/src/Data/Aeson/Decoding/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Decoding/Text.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -O2 #-} +-- | Parser from strict 'Text' to 'Tokens'. +module Data.Aeson.Decoding.Text ( + textToTokens, +) where + +import Data.Char (chr) +import Data.Integer.Conversion (textToInteger) +import Data.Text.Internal (Text (..)) + +import qualified Data.Aeson.Key as Key +import qualified Data.Scientific as Sci +import qualified Data.Text as T +import qualified Data.Text.Array as A + +import Data.Aeson.Decoding.Internal +import Data.Aeson.Decoding.Tokens +import Data.Aeson.Internal.Prelude +import Data.Aeson.Internal.UnescapeFromText (unescapeFromText) + +#if MIN_VERSION_text(2,0,0) +import qualified Data.Word8.Patterns as W +#else +import qualified Data.Word16.Patterns as W +#endif + +#if MIN_VERSION_text(2,0,0) +type Point = Word8 +#else +type Point = Word16 +#endif + + +-- | Lex (and parse) strict 'Text' into 'Tokens' stream. +-- +-- @since 2.2.1.0 +-- +textToTokens :: Text -> Tokens Text String +textToTokens bs0 = goT bs0 id where + goT :: Parser Tokens k + goT (skipSpace -> bs) k = case unconsPoint bs of + Nothing -> tkErr "Unexpected end-of-input, expecting JSON value" + Just (!w, !bs1) -> tokenCase w bs1 bs k + + tokenCase + :: Point -- head + -> Text -- tail + -> Text -- whole input, needed for number parsing + -> (Text -> k) -- continuation + -> Tokens k String + tokenCase W.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase w _ wbs k + | W.DIGIT_0 <= w, w <= W.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W.LOWER_N bs _ k + | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) + tokenCase W.LOWER_T bs _ k + | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) + tokenCase W.LOWER_F bs _ k + | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) + tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" + -- Array + goA :: Parser TkArray k + goA (skipSpace -> bs) k = case unconsPoint bs of + Nothing -> tkErrEOF "JSON value or ]" + Just (W.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k + + goA1 :: Parser TkArray k + goA1 (skipSpace -> bs) k = case unconsPoint bs of + Nothing -> tkErrEOF ", or ]" + Just (W.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + _ -> tkErrBS bs ", or ]" + + -- Record + goR :: Parser TkRecord k + goR (skipSpace -> bs) k = case unconsPoint bs of + Nothing -> tkErrEOF "record key literal or }" + Just (W.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just _ -> tkErrBS bs "record key literal or }" + + -- after record pair, expecting ," or } + goR1 :: Parser TkRecord k + goR1 (skipSpace -> bs) k = case unconsPoint bs of + Nothing -> tkErr "Unexpected end-of-input, expecting , or }" + Just (W.COMMA, !bs1) -> case unconsPoint (skipSpace bs1) of + Nothing -> tkErrEOF "key literal" + Just (W.DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just _ -> tkErrBS bs "key literal" + Just (W.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) + _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" + + -- key of record (after double quote) + goRK :: Parser TkRecord k + goRK bs1 k = scanStringLiteral (\t bs -> goRK' t bs k) tkErr bs1 + + -- after key of a record, expecting : + goRK' :: Text -> Parser TkRecord k + goRK' t (skipSpace -> bs) k = case T.uncons bs of + Nothing -> tkErrEOF ":" + Just (':', !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k + Just _ -> tkErrBS bs ":" + +stripPrefix :: Text -> Int -> Text -> Maybe Text +stripPrefix pfx _ bs = T.stripPrefix pfx bs +{-# INLINE stripPrefix #-} + +type Parser tk k = Text -> (Text -> k) -> tk k String + +showBeginning :: Text -> String +showBeginning = show . T.take 30 + +-- | Strip leading (ASCII) space +skipSpace :: Text -> Text +skipSpace = T.dropWhile $ \w -> w == '\x20' || w == '\x0a' || w == '\x0d' || w == '\x09' +{-# INLINE skipSpace #-} + +tkErrEOF :: AsError t => String -> t k String +tkErrEOF expected = tkErr $ + "Unexpected end-of-input, expecting " ++ expected +{-# INLINE tkErrEOF #-} + +tkErrBS :: AsError t => Text -> String -> t k String +tkErrBS bs expected = tkErr $ + "Unexpected " ++ showBeginning bs ++ ", expecting " ++ expected +{-# INLINE tkErrBS #-} + +------------------------------------------------------------------------------- +-- Text +------------------------------------------------------------------------------- + +scanStringLiteral + :: forall r. (Text -> Text -> r) + -> (String -> r) + -> Text + -> r +scanStringLiteral ok err bs0 = go 0 bs0 where + -- the length is counted in bytes. + go :: Int -> Text -> r + go !n !bs = case unconsPoint bs of + Nothing -> errEnd + Just (34, _) -> ok (unsafeTakePoints n bs0) (unsafeDropPoints (n + 1) bs0) + Just (92, bs') -> goSlash (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + -- we don't need to check for @>= 0x80@ chars, as text is valid unicode. + | otherwise -> go (n + 1) bs' + + -- in goEsc and goSlash we don't need to check for control characters as unescapeText verifies that. + goEsc :: Int -> Text -> r + goEsc !n !bs = case unconsPoint bs of + Nothing -> errEnd + Just (34, _) -> case unescapeFromText (unsafeTakePoints n bs0) of + Right t -> ok t (unsafeDropPoints (n + 1) bs0) + Left e -> err (show e) + Just (92, bs') -> goSlash (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' + + goSlash :: Int -> Text -> r + goSlash !n !bs = case unconsPoint bs of + Nothing -> errEnd + Just (_, bs') -> goEsc (n + 1) bs' + + errEnd = err "Unexpected end-of-input while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" + +------------------------------------------------------------------------------- +-- Number +------------------------------------------------------------------------------- + +-- +-- number := integer fraction exponent +-- integer := 0 | [1-9][0-9]* | -0 | -[1-9][0-9]* +-- fraction := "" | . [0-9]+ +-- exponent := "" | E sign [0-9]+ | e sign [0-9]+ +-- sign := "" | - | + +-- +-- This scanner doesn't recognize the leading minus sign, we recognize only integer := 0 | [1-9][0-9]*, +-- as the minus sign is recognized by outer scanner already. +-- +scanNumberLiteral + :: forall r. (Number -> Text -> r) + -> (String -> r) + -> Text + -> r +scanNumberLiteral kont err bs0 = state_start bs0 where + state_start :: Text -> r + state_start !bs = case unconsPoint bs of + Nothing -> errEnd + Just (w8, bs') + | W.DIGIT_0 < w8, w8 <= W.DIGIT_9 -> state_i1 1 bs' + | W.DIGIT_0 == w8 -> state_after0 bs' + | otherwise -> errUnx w8 + + state_after0 :: Text -> r + state_after0 !bs = case unconsPoint bs of + Nothing -> kont (NumInteger 0) bs + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> err "Number literal with leading zero" + | W.PERIOD == w8 -> go_dec 0 bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs + + state_i1 :: Int -> Text -> r + state_i1 !n !bs = case unconsPoint bs of + Nothing -> kont (NumInteger int) bs + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_i1 (n + 1) bs' + | W.PERIOD == w8 -> go_dec int bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs + where + int = textToInteger (unsafeTakePoints n bs0) + + go_dec :: Integer -> Text -> r + go_dec !int !bs1 = case unconsPoint bs1 of + Nothing -> errEnd + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_dec 1 bs' + | otherwise -> errUnx w8 + where + state_dec :: Int -> Text -> r + state_dec !n !bs = case unconsPoint bs of + Nothing -> kont (NumDecimal dec) bs + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_dec (n + 1) bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs + where + frac = textToInteger (unsafeTakePoints n bs1) + coef = int * 10 ^ n + frac + dec = Sci.scientific coef (negate n) + + go_sci :: Integer -> Int -> Text -> r + go_sci !coef !exp10 !bs2 = case unconsPoint bs2 of + Nothing -> errEnd + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W.PLUS == w8 -> case unconsPoint bs' of + Nothing -> errEnd + Just (w8', bs'') + | W.DIGIT_0 <= w8', w8' <= W.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | W.HYPHEN == w8 -> case unconsPoint bs' of + Nothing -> errEnd + Just (w8', bs'') + | W.DIGIT_0 <= w8', w8' <= W.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | otherwise -> errUnx w8 + + go_sci_pos :: Integer -> Int -> Text -> Int -> Text -> r + go_sci_pos !coef !exp10 !bs2 !n !bs = case unconsPoint bs of + Nothing -> kont (NumScientific sci) bs + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs + where + exp10' = fromInteger (textToInteger (unsafeTakePoints n bs2)) + sci = Sci.scientific coef (exp10 + exp10') + + go_sci_neg :: Integer -> Int -> Text -> Int -> Text -> r + go_sci_neg !coef !exp10 !bs2 !n !bs = case unconsPoint bs of + Nothing -> kont (NumScientific sci) bs + Just (w8, bs') + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs + where + exp10' = fromInteger (textToInteger (unsafeTakePoints n bs2)) + sci = Sci.scientific coef (exp10 - exp10') + + errEnd = err "Unexpected end-of-input while parsing number literal" + errUnx w8 = err $ "Unexpected " ++ show (chr (fromIntegral w8)) ++ " while parsing number literal" + +------------------------------------------------------------------------------- +-- Unsafe primitives +------------------------------------------------------------------------------- + +{-# INLINE unconsPoint #-} +-- Uncons a primitive unit of storage from text. +-- The left-over 'Text' value may be invalid. +unconsPoint :: Text -> Maybe (Point, Text) +unconsPoint (Text arr off len) + | len <= 0 = Nothing + | otherwise = Just (w8, Text arr (off + 1) (len - 1)) + where + w8 = A.unsafeIndex arr off + +unsafeTakePoints :: Int -> Text -> Text +unsafeTakePoints n (Text arr off _len) = Text arr off n +{-# INLINE unsafeTakePoints #-} + +unsafeDropPoints :: Int -> Text -> Text +unsafeDropPoints n (Text arr off len) = Text arr (off + n) (len - n) +{-# INLINE unsafeDropPoints #-} diff --git a/src/Data/Aeson/Decoding/Tokens.hs b/src/Data/Aeson/Decoding/Tokens.hs --- a/src/Data/Aeson/Decoding/Tokens.hs +++ b/src/Data/Aeson/Decoding/Tokens.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveTraversable #-} -- | Token definitions. module Data.Aeson.Decoding.Tokens ( -- * Types @@ -10,9 +9,9 @@ ) where import Data.Aeson.Key (Key) -import Data.Bifoldable.Compat (Bifoldable (..)) -import Data.Bifunctor.Compat (Bifunctor (..)) -import Data.Bitraversable.Compat (Bitraversable (..), bifoldMapDefault, bimapDefault) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault) import Data.Scientific (Scientific) import Data.Text (Text) diff --git a/src/Data/Aeson/Encoding/Builder.hs b/src/Data/Aeson/Encoding/Builder.hs --- a/src/Data/Aeson/Encoding/Builder.hs +++ b/src/Data/Aeson/Encoding/Builder.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} -- | -- Module: Data.Aeson.Encoding.Builder @@ -38,9 +37,8 @@ , ascii5 ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude -import Data.Attoparsec.Time.Internal import Data.Aeson.Types.Internal (Value (..), Key) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM @@ -50,14 +48,15 @@ import qualified Data.ByteString.Builder.Prim as BP import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.Char (chr, ord) -import Data.Scientific (Scientific, base10Exponent, coefficient) +import Data.Fixed (Fixed (..)) +import Data.Scientific (base10Exponent, coefficient) import Data.Text.Encoding (encodeUtf8BuilderEscaped) import Data.Time (UTCTime(..)) import Data.Time.Calendar (Day(..), toGregorian) import Data.Time.Calendar.Month.Compat (Month, toYearMonth) import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..)) import Data.Time.LocalTime (LocalTime (..), TimeZone (..), ZonedTime (..), TimeOfDay (..)) -import Data.Word (Word8) +import Data.Time.Clock.Compat (DiffTime, diffTimeToPicoseconds) import qualified Data.Text as T import qualified Data.Vector as V @@ -292,3 +291,28 @@ digit :: Int -> Char digit x = chr (x + 48) + +------------------------------------------------------------------------------- +-- TimeOfDay64 +------------------------------------------------------------------------------- + +-- | Like TimeOfDay, but using a fixed-width integer for seconds. +data TimeOfDay64 = TOD {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int64 + +toTimeOfDay64 :: TimeOfDay -> TimeOfDay64 +toTimeOfDay64 (TimeOfDay h m (MkFixed s)) = TOD h m (fromIntegral s) + +posixDayLength :: DiffTime +posixDayLength = 86400 + +diffTimeOfDay64 :: DiffTime -> TimeOfDay64 +diffTimeOfDay64 t + | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength)) + | otherwise = TOD (fromIntegral h) (fromIntegral m) s + where (h,mp) = pico t `quotRem` 3600000000000000 + (m,s) = mp `quotRem` 60000000000000 + pico = fromIntegral . diffTimeToPicoseconds + + diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs --- a/src/Data/Aeson/Encoding/Internal.hs +++ b/src/Data/Aeson/Encoding/Internal.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -62,20 +60,15 @@ , comma, colon, openBracket, closeBracket, openCurly, closeCurly ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude hiding (empty) import Data.Aeson.Types.Internal (Value, Key) import Data.ByteString.Builder (Builder, char7, toLazyByteString) import Data.ByteString.Short (ShortByteString) import qualified Data.Aeson.Key as Key -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Scientific (Scientific) -import Data.Text (Text) -import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter) -import Data.Typeable (Typeable) -import Data.Word (Word8, Word16, Word32, Word64) import qualified Data.Aeson.Encoding.Builder as EB import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BSL @@ -89,7 +82,7 @@ newtype Encoding' tag = Encoding { fromEncoding :: Builder -- ^ Acquire the underlying bytestring builder. - } deriving (Typeable) + } -- | Often used synonym for 'Encoding''. type Encoding = Encoding' Value @@ -122,6 +115,10 @@ compare (Encoding a) (Encoding b) = compare (toLazyByteString a) (toLazyByteString b) +-- | @since 2.2.0.0 +instance IsString (Encoding' a) where + fromString = string + -- | A series of values that, when encoded, should be separated by -- commas. Since 0.11.0.0, the '.=' operator is overloaded to create -- either @(Text, Value)@ or 'Series'. You can use Series when @@ -131,7 +128,6 @@ -- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age) data Series = Empty | Value (Encoding' Series) - deriving (Typeable) pair :: Key -> Encoding -> Series pair name val = pair' (key name) val diff --git a/src/Data/Aeson/Internal.hs b/src/Data/Aeson/Internal.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} --- | --- Module: Data.Aeson.Internal --- Copyright: (c) 2015-2016 Bryan O'Sullivan --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- Internal types and functions. --- --- __Note__: all declarations in this module are unstable, and prone --- to being changed at any time. - -module Data.Aeson.Internal - {-# DEPRECATED "All contents of this module are exported from Data.Aeson.Types module. This module will be removed in the next major aeson version." #-} - ( - IResult(..) - , JSONPathElement(..) - , JSONPath - , () - , formatError - , ifromJSON - , iparse - ) where - -import Data.Aeson.Types.Internal -import Data.Aeson.Types.FromJSON (ifromJSON) diff --git a/src/Data/Aeson/Internal/ByteString.hs b/src/Data/Aeson/Internal/ByteString.hs --- a/src/Data/Aeson/Internal/ByteString.hs +++ b/src/Data/Aeson/Internal/ByteString.hs @@ -5,34 +5,37 @@ module Data.Aeson.Internal.ByteString ( mkBS, withBS, +#ifdef MIN_VERSION_template_haskell liftSBS, +#endif ) where import Data.ByteString.Internal (ByteString (..)) import Data.Word (Word8) import Foreign.ForeignPtr (ForeignPtr) + +#if !MIN_VERSION_bytestring(0,11,0) +import GHC.ForeignPtr (plusForeignPtr) +#endif + +#ifdef MIN_VERSION_template_haskell import Data.ByteString.Short (ShortByteString, fromShort) -import GHC.Exts (Addr#, Ptr (Ptr)) import Data.ByteString.Short.Internal (createFromPtr) +import GHC.Exts (Addr#, Ptr (Ptr)) import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -#if !MIN_VERSION_bytestring(0,11,0) -#if MIN_VERSION_base(4,10,0) -import GHC.ForeignPtr (plusForeignPtr) -#else -import GHC.ForeignPtr (ForeignPtr(ForeignPtr)) -import GHC.Types (Int (..)) -import GHC.Prim (plusAddr#) -#endif -#endif - #if !MIN_VERSION_template_haskell(2,16,0) import qualified Data.ByteString as BS #endif +#endif +------------------------------------------------------------------------------- +-- bytestring-0.11 compat +------------------------------------------------------------------------------- + mkBS :: ForeignPtr Word8 -> Int -> ByteString #if MIN_VERSION_bytestring(0,11,0) mkBS dfp n = BS dfp n @@ -49,24 +52,11 @@ #endif {-# INLINE withBS #-} -#if !MIN_VERSION_bytestring(0,11,0) -#if !MIN_VERSION_base(4,10,0) --- |Advances the given address by the given offset in bytes. --- --- The new 'ForeignPtr' shares the finalizer of the original, --- equivalent from a finalization standpoint to just creating another --- reference to the original. That is, the finalizer will not be --- called before the new 'ForeignPtr' is unreachable, nor will it be --- called an additional time due to this call, and the finalizer will --- be called with the same address that it would have had this call --- not happened, *not* the new address. -plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b -plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts -{-# INLINE [0] plusForeignPtr #-} -{-# RULES "ByteString plusForeignPtr/0" forall fp . plusForeignPtr fp 0 = fp #-} -#endif -#endif +------------------------------------------------------------------------------- +-- Template Haskell +------------------------------------------------------------------------------- +#ifdef MIN_VERSION_template_haskell liftSBS :: ShortByteString -> TH.ExpQ #if MIN_VERSION_template_haskell(2,16,0) liftSBS sbs = withBS bs $ \ptr len -> [| unsafePackLenLiteral |] @@ -86,3 +76,4 @@ unsafePackLenLiteral :: Int -> Addr# -> ShortByteString unsafePackLenLiteral len addr# = unsafeDupablePerformIO $ createFromPtr (Ptr addr#) len +#endif diff --git a/src/Data/Aeson/Internal/Functions.hs b/src/Data/Aeson/Internal/Functions.hs --- a/src/Data/Aeson/Internal/Functions.hs +++ b/src/Data/Aeson/Internal/Functions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -- | -- Module: Data.Aeson.Functions -- Copyright: (c) 2011-2016 Bryan O'Sullivan @@ -14,8 +13,6 @@ , mapKeyValO , mapKeyO ) where - -import Prelude.Compat import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as H diff --git a/src/Data/Aeson/Internal/Integer.hs b/src/Data/Aeson/Internal/Integer.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal/Integer.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Data.Aeson.Internal.Integer ( - bsToInteger, - bsToIntegerSimple -) where - -import qualified Data.ByteString as B - -import Data.Aeson.Internal.Word8 - ------------------- Copy-pasted and adapted from base ------------------------ - -bsToInteger :: B.ByteString -> Integer -bsToInteger bs - | l > 40 = valInteger 10 l [ fromIntegral (w - W8_0) | w <- B.unpack bs ] - | otherwise = bsToIntegerSimple bs - where - l = B.length bs - -bsToIntegerSimple :: B.ByteString -> Integer -bsToIntegerSimple = B.foldl' step 0 where - step a b = a * 10 + fromIntegral (b - W8_0) - --- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b --- digits are combined into a single radix b^2 digit. This process is --- repeated until we are left with a single digit. This algorithm --- performs well only on large inputs, so we use the simple algorithm --- for smaller inputs. -valInteger :: Integer -> Int -> [Integer] -> Integer -valInteger = go - where - go :: Integer -> Int -> [Integer] -> Integer - go _ _ [] = 0 - go _ _ [d] = d - go b l ds - | l > 40 = b' `seq` go b' l' (combine b ds') - | otherwise = valSimple b ds - where - -- ensure that we have an even number of digits - -- before we call combine: - ds' = if even l then ds else 0 : ds - b' = b * b - l' = (l + 1) `quot` 2 - - combine b (d1 : d2 : ds) = d `seq` (d : combine b ds) - where - d = d1 * b + d2 - combine _ [] = [] - combine _ [_] = errorWithoutStackTrace "this should not happen" - --- The following algorithm is only linear for types whose Num operations --- are in constant time. -valSimple :: Integer -> [Integer] -> Integer -valSimple base = go 0 - where - go r [] = r - go r (d : ds) = r' `seq` go r' ds - where - r' = r * base + fromIntegral d diff --git a/src/Data/Aeson/Internal/Prelude.hs b/src/Data/Aeson/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Prelude.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} + +-- Prelude additions for @aeson@, reducing the amount of imports per module. +module Data.Aeson.Internal.Prelude ( + module X, +) where + +import Control.Applicative as X (Alternative (..), Const(..), liftA2) +import Control.Monad as X (void, when, unless, liftM2) +import Control.Monad.Fix as X (MonadFix (..)) +import Data.Coerce as X (Coercible, coerce) +import Data.Data as X (Data) +import Data.Foldable as X (foldl') +import Data.Function as X (fix) +import Data.Functor as X (($>)) +import Data.Int as X (Int8, Int16, Int32, Int64) +import Data.Maybe as X (fromMaybe, catMaybes, mapMaybe) +import Data.Proxy as X (Proxy(..)) +import Data.Scientific as X (Scientific) +import Data.Semigroup as X (Semigroup (..)) +import Data.String as X (IsString(..)) +import Data.Text as X (Text) +import Data.Time as X (UTCTime) +import Data.Vector as X (Vector) +import Data.Void as X (Void, absurd) +import Data.Word as X (Word8, Word16, Word32, Word64) +import GHC.Generics as X (Generic) +import Numeric.Natural as X (Natural) + +#if !MIN_VERSION_base(4,17,0) +import GHC.Generics.Generically as X (Generically (..), Generically1 (..)) +#endif diff --git a/src/Data/Aeson/Internal/Scientific.hs b/src/Data/Aeson/Internal/Scientific.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Scientific.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Aeson.Internal.Scientific ( + scanScientific, +) where + +import Data.Integer.Conversion (textToInteger) +import Data.Scientific (Scientific) +import Data.Text (Text) + +import qualified Data.Scientific as Sci +import qualified Data.Text as T + +-- | Parse 'Scientific' number from 'Text'. +-- +-- This is different from how JSON numbers are parsed: arbitrary leading zeroes are accepted. +-- +scanScientific + :: forall r. (Scientific -> Text -> r) + -> (String -> r) + -> Text + -> r +scanScientific kont err input0 = case T.uncons input0 of + Nothing -> errEnd + Just (c, text') + | c == '+' -> scanScientific' kont err text' + | c == '-' -> scanScientific' (\sci -> kont (negate sci)) err text' + | otherwise -> scanScientific' kont err input0 + where + errEnd = err "Unexpected end-of-input while parsing number literal" + +scanScientific' + :: forall r. (Scientific -> Text -> r) + -> (String -> r) + -> Text + -> r +scanScientific' kont err input0 = state_start input0 where + state_start :: Text -> r + state_start !text = case T.uncons text of + Nothing -> errEnd + Just (c, text') + | '0' <= c, c <= '9' -> state_i 1 text' + | otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal" + + state_i :: Int -> Text -> r + state_i !n !text = case T.uncons text of + Nothing -> kont (fromInteger int) text + Just (c, text') + | '0' <= c, c <= '9' -> state_i (n + 1) text' + | '.' == c -> go_dec int text' + | 'e' == c || 'E' == c -> go_sci int 0 text' + | otherwise -> kont (fromInteger int) text + where + int = textToInteger (T.take n input0) + + go_dec :: Integer -> Text -> r + go_dec !int !text1 = case T.uncons text1 of + Nothing -> errEnd + Just (c, text') + | '0' <= c, c <= '9' -> state_dec 1 text' + | otherwise -> err $ "Unexpected " ++ show c ++ " while parsing number literal" + where + state_dec :: Int -> Text -> r + state_dec !n !text = case T.uncons text of + Nothing -> kont dec text + Just (c, text') + | '0' <= c, c <= '9' -> state_dec (n + 1) text' + | 'e' == c || 'E' == c -> go_sci coef (negate n) text' + | otherwise -> kont dec text + where + frac = textToInteger (T.take n text1) + coef = int * 10 ^ n + frac + dec = Sci.scientific coef (negate n) + + go_sci :: Integer -> Int -> Text -> r + go_sci !coef !exp10 !text2 = case T.uncons text2 of + Nothing -> errEnd + Just (c, text') + | '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 1 text' + | '+' == c -> case T.uncons text' of + Nothing -> errEnd + Just (c', text'') + | '0' <= c', c' <= '9' -> go_sci_pos coef exp10 text' 1 text'' + | otherwise -> errUnx c' + | '-' == c -> case T.uncons text' of + Nothing -> errEnd + Just (c', text'') + | '0' <= c', c' <= '9' -> go_sci_neg coef exp10 text' 1 text'' + | otherwise -> errUnx c' + | otherwise -> errUnx c + + go_sci_pos :: Integer -> Int -> Text -> Int -> Text -> r + go_sci_pos !coef !exp10 !text2 !n !text = case T.uncons text of + Nothing -> kont sci text + Just (c, text') + | '0' <= c, c <= '9' -> go_sci_pos coef exp10 text2 (n + 1) text' + | otherwise -> kont sci text + where + exp10' = fromInteger (textToInteger (T.take n text2)) + sci = Sci.scientific coef (exp10 + exp10') + + go_sci_neg :: Integer -> Int -> Text -> Int -> Text -> r + go_sci_neg !coef !exp10 !text2 !n !text = case T.uncons text of + Nothing -> kont sci text + Just (c, text') + | '0' <= c, c <= '9' -> go_sci_neg coef exp10 text2 (n + 1) text' + | otherwise -> kont sci text + where + exp10' = fromInteger (textToInteger (T.take n text2)) + sci = Sci.scientific coef (exp10 - exp10') + + errEnd = err "Unexpected end-of-input while parsing number literal" + errUnx c = err $ "Unexpected " ++ show c ++ " while parsing number literal" diff --git a/src/Data/Aeson/Internal/Text.hs b/src/Data/Aeson/Internal/Text.hs --- a/src/Data/Aeson/Internal/Text.hs +++ b/src/Data/Aeson/Internal/Text.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T #if MIN_VERSION_text(2,0,0) -import Data.Text.Array (Array (..)) +import qualified Data.Text.Array as A import qualified Data.Text.Internal as T (Text (..)) import qualified Data.ByteString.Short.Internal as SBS @@ -27,7 +27,7 @@ #if MIN_VERSION_text(2,0,0) unsafeDecodeASCII bs = withBS bs $ \_fp len -> if len == 0 then T.empty else - let !(SBS.SBS arr) = SBS.toShort bs in T.Text (ByteArray arr) 0 len + let !(SBS.SBS arr) = SBS.toShort bs in T.Text (A.ByteArray arr) 0 len #else unsafeDecodeASCII = TE.decodeLatin1 diff --git a/src/Data/Aeson/Internal/Time.hs b/src/Data/Aeson/Internal/Time.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal/Time.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module: Data.Aeson.Internal.Time --- Copyright: (c) 2015-2016 Bryan O'Sullivan --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable - -module Data.Aeson.Internal.Time - {-# DEPRECATED "This module will be removed in the next major aeson version." #-} - ( - TimeOfDay64(..) - , fromPico - , toPico - , diffTimeOfDay64 - , toTimeOfDay64 - ) where - -import Data.Attoparsec.Time.Internal diff --git a/src/Data/Aeson/Internal/Unescape.hs b/src/Data/Aeson/Internal/Unescape.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Unescape.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module Data.Aeson.Internal.Unescape + ( unescapeText + ) where + +import Control.Exception (throwIO, try) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding.Error (UnicodeException (..)) +import Data.Text.Unsafe (unsafeDupablePerformIO) +import Data.Word (Word32, Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek) + +import qualified Data.Primitive as P +import qualified Data.Text.Array as T +import qualified Data.Text.Internal as T + +import Data.Aeson.Internal.ByteString + +#if !MIN_VERSION_text(2,0,0) +import Data.Word (Word16) +#endif + +-- | Unescape JSON text literal. +-- +-- This function is exported mostly for testing and benchmarking purposes. +unescapeText :: ByteString -> Either UnicodeException Text +unescapeText = unsafeDupablePerformIO . try . unescapeTextIO + +throwDecodeError :: IO a +throwDecodeError = + let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + in throwIO (DecodeError desc Nothing) + +------------------------------------------------------------------------------- +-- unescapeTextIO +------------------------------------------------------------------------------- + +-- This function is generated using staged-streams +-- See: https://github.com/phadej/staged/blob/master/staged-streams-unicode/src/Unicode/JSON.hs +-- +-- Because @aeson@ better to not use template-haskell itself, +-- we dump the splice and prettify it by hand a bit. +-- +unescapeTextIO :: ByteString -> IO Text + +#if MIN_VERSION_text(2,0,0) + +unescapeTextIO bs = withBS bs $ \fptr len -> + withForeignPtr fptr $ \begin -> do + let end :: Ptr Word8 + end = plusPtr begin len + + arr <- P.newPrimArray len + + let write3bytes :: Int -> Word8 -> Word8 -> Word8 -> Ptr Word8 -> IO Text + write3bytes !out !b1 !b2 !b3 !inp = do + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 b3 inp + + write2bytes :: Int -> Word8 -> Word8 -> Ptr Word8 -> IO Text + write2bytes !out !b1 !b2 !inp = do + P.writePrimArray arr out b1 + write1byte (out + 1) b2 inp + + write1byte :: Int -> Word8 -> Ptr Word8 -> IO Text + write1byte !out !b1 !inp = do + P.writePrimArray arr out b1 + state_start (out + 1) inp + + writeCodePoint :: Int -> Ptr Word8 -> Word32 -> IO Text + writeCodePoint !out !inp !acc + | acc <= 127 = do + P.writePrimArray arr out (fromIntegral acc :: Word8) + state_start (out + 1) (plusPtr inp 1) + + | acc <= 2047 = do + let b1 = fromIntegral (shiftR acc 6 .|. 192) :: Word8 + let b2 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write1byte (out + 1) b2 (plusPtr inp 1) + + | acc <= 65535 = do + let b1 = fromIntegral (shiftR acc 12 .|. 224) :: Word8 + let b2 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 + let b3 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 b3 (plusPtr inp 1) + + | otherwise = do + let b1 = fromIntegral (shiftR acc 18 .|. 240) :: Word8 + let b2 = fromIntegral ((shiftR acc 12 .&. 63) .|. 128) :: Word8 + let b3 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 + let b4 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write3bytes (out + 1) b2 b3 b4 (plusPtr inp 1) + + state_sudone :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_sudone !out !inp !hi !lo + | 56320 <= lo, lo <= 57343 + = writeCodePoint out inp (65536 + (shiftL (hi - 55296) 10 .|. (lo - 56320))) + + | otherwise + = throwDecodeError + + state_su4 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su4 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su3 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su3 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su2 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su2 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su1 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su1 !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 117 -> state_su1 out (plusPtr inp 1) hi + _ -> throwDecodeError + + state_ss :: Int -> Ptr Word8 -> Word32 -> IO Text + state_ss !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 92 -> state_su out (plusPtr inp 1) hi + _ -> throwDecodeError + + state_udone :: Int -> Ptr Word8 -> Word32 -> IO Text + state_udone !out !inp !acc + | acc < 55296 || acc > 57343 = + writeCodePoint out inp acc + + | acc < 56320 = + state_ss out (plusPtr inp 1) acc + + | otherwise = + throwDecodeError + + state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u1 :: Int -> Ptr Word8 -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_escape :: Int -> Ptr Word8 -> IO Text + state_escape !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (plusPtr inp 1) + + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (plusPtr inp 1) + + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (plusPtr inp 1) + + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (plusPtr inp 1) + + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (plusPtr inp 1) + + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (plusPtr inp 1) + + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (plusPtr inp 1) + + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (plusPtr inp 1) + + 117 -> + state_u1 out (plusPtr inp 1) + + _ -> throwDecodeError + + state_input4c :: Int -> Ptr Word8 -> Word8 -> Word8 -> Word8 -> IO Text + state_input4c !out !inp !b1 !b2 !b3 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 + , let acc = shiftL (fromIntegral (b1 .&. 7)) 18 + , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 12 + , let acc'' = acc' .|. shiftL (fromIntegral (b3 .&. 63)) 6 + , let acc''' = acc'' .|. fromIntegral (w8 .&. 63) :: Word32 + , acc''' >= 65536 && acc''' < 1114112 -> do + P.writePrimArray arr out b1 + write3bytes (out + 1) b2 b3 w8 (plusPtr inp 1) + + | otherwise -> + throwDecodeError + + state_input4b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text + state_input4b !out !inp !b1 !b2 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input4c out (plusPtr inp 1) b1 b2 w8 + + | otherwise -> + throwDecodeError + + state_input4 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input4 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input4b out (plusPtr inp 1) b1 w8 + + | otherwise -> + throwDecodeError + + state_input3b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text + state_input3b !out !inp !b1 !b2 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 + , let acc = shiftL (fromIntegral (b1 .&. 15)) 12 + , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 6 + , let acc'' = acc' .|. fromIntegral (w8 .&. 63) :: Word32 + , (acc'' >= 2048 && acc'' < 55296) || acc'' > 57343 -> do + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 w8 (plusPtr inp 1) + + | otherwise -> + throwDecodeError + + state_input3 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input3 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input3b out (plusPtr inp 1) b1 w8 + + | otherwise -> + throwDecodeError + + state_input2 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input2 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128, + let acc = shiftL (fromIntegral (b1 .&. 63)) 6 :: Word32 + acc' = acc .|. fromIntegral (w8 .&. 63) :: Word32 + , acc' >= 128 -> do + P.writePrimArray arr out b1 + write1byte (out + 1) w8 (plusPtr inp 1) + + | otherwise -> + throwDecodeError + + state_start :: Int -> Ptr Word8 -> IO Text + state_start !out !inp + | inp == end = do + P.shrinkMutablePrimArray arr out + frozenArr <- P.unsafeFreezePrimArray arr + return $ case frozenArr of + P.PrimArray ba -> T.Text (T.ByteArray ba) 0 out + + | otherwise = do + w8 <- peek inp + if | w8 == 92 -> state_escape out (plusPtr inp 1) + | w8 < 128 -> do + P.writePrimArray arr out w8 + state_start (out + 1) (plusPtr inp 1) + + | w8 < 192 -> throwDecodeError + | w8 < 224 -> state_input2 out (plusPtr inp 1) w8 + | w8 < 240 -> state_input3 out (plusPtr inp 1) w8 + | w8 < 248 -> state_input4 out (plusPtr inp 1) w8 + + | otherwise -> throwDecodeError + + -- start the state machine + state_start (0 :: Int) begin +#else + +unescapeTextIO bs = withBS bs $ \fptr len -> + withForeignPtr fptr $ \begin -> do + let end :: Ptr Word8 + end = plusPtr begin len + + arr <- P.newPrimArray len + + let writeLowSurrogate :: Int -> Word16 -> Ptr Word8 -> IO Text + writeLowSurrogate !out !w16 !inp = do + P.writePrimArray arr out w16 + state_start (out + 1) inp + + state_sudone :: Int -> Ptr Word8 -> Word32 -> IO Text + state_sudone !out !inp !lo + | 56320 <= lo, lo <= 57343 = do + P.writePrimArray arr out (fromIntegral lo) + state_start (out + 1) (plusPtr inp 1) + + | otherwise = + throwDecodeError + + state_su4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> throwDecodeError + + state_su2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su1 :: Int -> Ptr Word8 -> IO Text + state_su1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + -- high surrogate u + state_su :: Int -> Ptr Word8 -> IO Text + state_su !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 117 -> state_su1 out (plusPtr inp 1) + _ -> throwDecodeError + + -- high surrogate slash + state_ss :: Int -> Ptr Word8 -> IO Text + state_ss !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 92 -> state_su out (plusPtr inp 1) + _ -> throwDecodeError + + state_udone :: Int -> Ptr Word8 -> Word32 -> IO Text + state_udone !out !inp !acc + -- we know that codepoint in acc is in BMP + | acc < 55296 || acc > 57343 = do + P.writePrimArray arr out (fromIntegral acc) + state_start (out + 1) (plusPtr inp 1) + + -- hi surrogate, + -- we write it immediately (UTF16 as an output!) + | acc < 56320 = do + P.writePrimArray arr out (fromIntegral acc) + state_ss (out + 1) (plusPtr inp 1) + + | otherwise = + throwDecodeError + + state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u1 :: Int -> Ptr Word8 -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_escape :: Int -> Ptr Word8 -> IO Text + state_escape out inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (plusPtr inp 1) + + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (plusPtr inp 1) + + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (plusPtr inp 1) + + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (plusPtr inp 1) + + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (plusPtr inp 1) + + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (plusPtr inp 1) + + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (plusPtr inp 1) + + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (plusPtr inp 1) + + 117 -> + state_u1 out (plusPtr inp 1) + + _ -> throwDecodeError + + state_input4c :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4c !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , acc' >= 65536 && acc' < 1114112 -> + if {- -- | acc' < 65536 -> do + -- P.writePrimArray arr out (fromIntegral acc' :: Word16) + -- state_start (out + 1) (plusPtr inp 1) -} + | otherwise -> do + let u = acc' - 65536 + hi = fromIntegral (55296 + shiftR u 10) :: Word16 + lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 + P.writePrimArray arr out hi + writeLowSurrogate (out + 1) lo (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_input4b :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4b !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input4c out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) + + | otherwise -> throwDecodeError + + state_input4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input4b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 12) + + | otherwise -> throwDecodeError + + state_input3b :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input3b !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , (acc' >= 2048 && acc' < 55296) || acc' > 57343 -> + if | acc' < 65536 -> do + P.writePrimArray arr out (fromIntegral acc') + state_start (out + 1) (plusPtr inp 1) + + | otherwise -> do + let u = acc' - 65536 + hi = fromIntegral (55296 + shiftR u 10) :: Word16 + lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 + P.writePrimArray arr out hi + writeLowSurrogate (out + 1) lo (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_input3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input3b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) + | otherwise -> throwDecodeError + + state_input2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , acc' >= 0x80 -> do + P.writePrimArray arr out (fromIntegral acc' :: Word16) + state_start (out + 1) (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_start :: Int -> Ptr Word8 -> IO Text + state_start !out !inp + | inp == end = do + P.shrinkMutablePrimArray arr out + frozenArr <- P.unsafeFreezePrimArray arr + return $ case frozenArr of + P.PrimArray ba -> T.Text (T.Array ba) 0 out + + | otherwise = do + w8 <- peek inp + if | w8 == 92 -> state_escape out (plusPtr inp 1) + | w8 < 0x80 -> do + P.writePrimArray arr out (fromIntegral w8 :: Word16) + state_start (out + 1) (plusPtr inp 1) + + | w8 < 0xc0 -> throwDecodeError + | w8 < 224 -> state_input2 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 63)) 6) + | w8 < 240 -> state_input3 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 15)) 12) + | w8 < 248 -> state_input4 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 7)) 18) + | otherwise -> throwDecodeError + + -- start the state machine + state_start (0 :: Int) begin + +#endif diff --git a/src/Data/Aeson/Internal/UnescapeFromText.hs b/src/Data/Aeson/Internal/UnescapeFromText.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/UnescapeFromText.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module Data.Aeson.Internal.UnescapeFromText + ( unescapeFromText + ) where + +import Control.Exception (throwIO, try) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.Text.Encoding.Error (UnicodeException (..)) +import Data.Text.Internal (Text (..)) +import Data.Text.Unsafe (unsafeDupablePerformIO) + +import Data.Aeson.Internal.Prelude + +import qualified Data.Primitive as P +import qualified Data.Text.Array as A +import qualified Data.Text.Internal as T + +#if !MIN_VERSION_text(2,0,0) +import Data.Word (Word16) +#endif + +-- | Unescape JSON text literal. +-- +-- This function is exported mostly for testing and benchmarking purposes. +unescapeFromText :: Text -> Either UnicodeException Text +unescapeFromText = unsafeDupablePerformIO . try . unescapeFromTextIO + +throwDecodeError :: IO a +throwDecodeError = + let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + in throwIO (DecodeError desc Nothing) + +------------------------------------------------------------------------------- +-- unescapeTextIO +------------------------------------------------------------------------------- + +type Offset = Int + +unescapeFromTextIO :: Text -> IO Text + +#if MIN_VERSION_text(2,0,0) + +unescapeFromTextIO (Text src begin len) = do + let end :: Offset + end = begin + len + + arr <- P.newPrimArray len + + let write3bytes :: Int -> Word8 -> Word8 -> Word8 -> Offset -> IO Text + write3bytes !out !b1 !b2 !b3 !inp = do + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 b3 inp + + write2bytes :: Int -> Word8 -> Word8 -> Offset -> IO Text + write2bytes !out !b1 !b2 !inp = do + P.writePrimArray arr out b1 + write1byte (out + 1) b2 inp + + write1byte :: Int -> Word8 -> Offset -> IO Text + write1byte !out !b1 !inp = do + P.writePrimArray arr out b1 + state_start (out + 1) inp + + writeCodePoint :: Int -> Offset -> Word32 -> IO Text + writeCodePoint !out !inp !acc + | acc <= 127 = do + P.writePrimArray arr out (fromIntegral acc :: Word8) + state_start (out + 1) (inp + 1) + + | acc <= 2047 = do + let b1 = fromIntegral (shiftR acc 6 .|. 192) :: Word8 + let b2 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write1byte (out + 1) b2 (inp + 1) + + | acc <= 65535 = do + let b1 = fromIntegral (shiftR acc 12 .|. 224) :: Word8 + let b2 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 + let b3 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 b3 (inp + 1) + + | otherwise = do + let b1 = fromIntegral (shiftR acc 18 .|. 240) :: Word8 + let b2 = fromIntegral ((shiftR acc 12 .&. 63) .|. 128) :: Word8 + let b3 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8 + let b4 = fromIntegral ((acc .&. 63) .|. 128) :: Word8 + P.writePrimArray arr out b1 + write3bytes (out + 1) b2 b3 b4 (inp + 1) + + state_sudone :: Int -> Offset -> Word32 -> Word32 -> IO Text + state_sudone !out !inp !hi !lo + | 56320 <= lo, lo <= 57343 + = writeCodePoint out inp (65536 + (shiftL (hi - 55296) 10 .|. (lo - 56320))) + + | otherwise + = throwDecodeError + + state_su4 :: Int -> Offset -> Word32 -> Word32 -> IO Text + state_su4 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su3 :: Int -> Offset -> Word32 -> Word32 -> IO Text + state_su3 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su2 :: Int -> Offset -> Word32 -> Word32 -> IO Text + state_su2 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su1 :: Int -> Offset -> Word32 -> IO Text + state_su1 !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (inp + 1) hi (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (inp + 1) hi (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (inp + 1) hi (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su :: Int -> Offset -> Word32 -> IO Text + state_su !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 117 -> state_su1 out (inp + 1) hi + _ -> throwDecodeError + + state_ss :: Int -> Offset -> Word32 -> IO Text + state_ss !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 92 -> state_su out (inp + 1) hi + _ -> throwDecodeError + + state_udone :: Int -> Offset -> Word32 -> IO Text + state_udone !out !inp !acc + | acc < 55296 || acc > 57343 = + writeCodePoint out inp acc + + | acc < 56320 = + state_ss out (inp + 1) acc + + | otherwise = + throwDecodeError + + state_u4 :: Int -> Offset -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u3 :: Int -> Offset -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u2 :: Int -> Offset -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u1 :: Int -> Offset -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_escape :: Int -> Offset -> IO Text + state_escape !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (inp + 1) + + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (inp + 1) + + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (inp + 1) + + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (inp + 1) + + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (inp + 1) + + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (inp + 1) + + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (inp + 1) + + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (inp + 1) + + 117 -> + state_u1 out (inp + 1) + + _ -> throwDecodeError + + state_start :: Int -> Offset -> IO Text + state_start !out !inp + | inp == end = do + P.shrinkMutablePrimArray arr out + frozenArr <- P.unsafeFreezePrimArray arr + return $ case frozenArr of + P.PrimArray ba -> T.Text (A.ByteArray ba) 0 out + + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | w8 == 92 -> state_escape out (inp + 1) + -- because we are deserialising __valid__ text, + -- we can simply copy everything else. + | otherwise -> do + P.writePrimArray arr out w8 + state_start (out + 1) (inp + 1) + + -- start the state machine + state_start (0 :: Int) begin +#else + +unescapeFromTextIO (Text src begin len) = do + let end :: Offset + end = begin + len + + arr <- P.newPrimArray len + + let state_sudone :: Int -> Offset -> Word32 -> IO Text + state_sudone !out !inp !lo + | 56320 <= lo, lo <= 57343 = do + P.writePrimArray arr out (fromIntegral lo) + state_start (out + 1) (inp + 1) + + | otherwise = + throwDecodeError + + state_su4 :: Int -> Offset -> Word32 -> IO Text + state_su4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su3 :: Int -> Offset -> Word32 -> IO Text + state_su3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> throwDecodeError + + state_su2 :: Int -> Offset -> Word32 -> IO Text + state_su2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su1 :: Int -> Offset -> IO Text + state_su1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (inp + 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (inp + 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (inp + 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + -- high surrogate u + state_su :: Int -> Offset -> IO Text + state_su !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 117 -> state_su1 out (inp + 1) + _ -> throwDecodeError + + -- high surrogate slash + state_ss :: Int -> Offset -> IO Text + state_ss !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 92 -> state_su out (inp + 1) + _ -> throwDecodeError + + state_udone :: Int -> Offset -> Word32 -> IO Text + state_udone !out !inp !acc + -- we know that codepoint in acc is in BMP + | acc < 55296 || acc > 57343 = do + P.writePrimArray arr out (fromIntegral acc) + state_start (out + 1) (inp + 1) + + -- hi surrogate, + -- we write it immediately (UTF16 as an output!) + | acc < 56320 = do + P.writePrimArray arr out (fromIntegral acc) + state_ss (out + 1) (inp + 1) + + | otherwise = + throwDecodeError + + state_u4 :: Int -> Offset -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u3 :: Int -> Offset -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u2 :: Int -> Offset -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u1 :: Int -> Offset -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (inp + 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_escape :: Int -> Offset -> IO Text + state_escape out inp + | inp == end = throwDecodeError + | otherwise = do + let !w8 = A.unsafeIndex src inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (inp + 1) + + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (inp + 1) + + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (inp + 1) + + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (inp + 1) + + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (inp + 1) + + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (inp + 1) + + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (inp + 1) + + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (inp + 1) + + 117 -> + state_u1 out (inp + 1) + + _ -> throwDecodeError + + state_start :: Int -> Offset -> IO Text + state_start !out !inp + | inp == end = do + P.shrinkMutablePrimArray arr out + frozenArr <- P.unsafeFreezePrimArray arr + return $ case frozenArr of + P.PrimArray ba -> T.Text (A.Array ba) 0 out + + | otherwise = do + let !w8 = A.unsafeIndex src inp + if | w8 == 92 -> state_escape out (inp + 1) + -- because we are deserialising __valid__ text, + -- we can simply copy everything else. + | otherwise -> do + P.writePrimArray arr out (fromIntegral w8 :: Word16) + state_start (out + 1) (inp + 1) + + -- start the state machine + state_start (0 :: Int) begin + +#endif diff --git a/src/Data/Aeson/Internal/Word8.hs b/src/Data/Aeson/Internal/Word8.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal/Word8.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Data.Aeson.Internal.Word8 where - -import Data.Word (Word8) - -------------------------------------------------------------------------------- --- Word8 ASCII codes as patterns -------------------------------------------------------------------------------- - --- GHC-8.0 doesn't support giving multiple pattern synonyms type signature at once - --- spaces -pattern W8_SPACE :: Word8 -pattern W8_NL :: Word8 -pattern W8_CR :: Word8 -pattern W8_TAB :: Word8 - -pattern W8_SPACE = 0x20 -pattern W8_NL = 0x0a -pattern W8_CR = 0x0d -pattern W8_TAB = 0x09 - --- punctuation -pattern W8_BACKSLASH :: Word8 -pattern W8_DOUBLE_QUOTE :: Word8 -pattern W8_DOT :: Word8 -pattern W8_COMMA :: Word8 -pattern W8_COLON :: Word8 - -pattern W8_BACKSLASH = 92 -pattern W8_COMMA = 44 -pattern W8_DOT = 46 -pattern W8_DOUBLE_QUOTE = 34 -pattern W8_COLON = 58 - --- parentheses -pattern W8_CLOSE_CURLY :: Word8 -pattern W8_CLOSE_SQUARE :: Word8 -pattern W8_OPEN_SQUARE :: Word8 -pattern W8_OPEN_CURLY :: Word8 - -pattern W8_OPEN_CURLY = 123 -pattern W8_OPEN_SQUARE = 91 -pattern W8_CLOSE_CURLY = 125 -pattern W8_CLOSE_SQUARE = 93 - --- operators -pattern W8_MINUS :: Word8 -pattern W8_PLUS :: Word8 - -pattern W8_PLUS = 43 -pattern W8_MINUS = 45 - --- digits -pattern W8_0 :: Word8 -pattern W8_9 :: Word8 - -pattern W8_0 = 48 -pattern W8_9 = 57 - --- lower case -pattern W8_e :: Word8 -pattern W8_f :: Word8 -pattern W8_n :: Word8 -pattern W8_t :: Word8 - -pattern W8_e = 101 -pattern W8_f = 102 -pattern W8_n = 110 -pattern W8_t = 116 - --- upper case -pattern W8_E :: Word8 -pattern W8_E = 69 diff --git a/src/Data/Aeson/Key.hs b/src/Data/Aeson/Key.hs --- a/src/Data/Aeson/Key.hs +++ b/src/Data/Aeson/Key.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskellQuotes #-} -- | @@ -29,7 +32,6 @@ import Data.Semigroup (Semigroup((<>))) import Data.Text (Text) import Data.Type.Coercion (Coercion (..)) -import Data.Typeable (Typeable) import Text.Read (Read (..)) import qualified Data.String @@ -39,7 +41,7 @@ import qualified Test.QuickCheck as QC newtype Key = Key { unKey :: Text } - deriving (Eq, Ord, Typeable, Data) + deriving (Data) fromString :: String -> Key fromString = Key . T.pack @@ -58,7 +60,7 @@ -- -- Using 'coercing' we can make more efficient implementations -- when 'Key' is backed up by 'Text' without exposing internals. --- +-- coercionToText :: Maybe (Coercion Key Text) coercionToText = Just Coercion {-# INLINE coercionToText #-} @@ -79,13 +81,14 @@ readPrec = fromString <$> readPrec instance Show Key where - showsPrec d (Key k) = showsPrec d k + showsPrec d (Key k) = showsPrec d k instance Data.String.IsString Key where fromString = fromString -instance Hashable Key where - hashWithSalt salt (Key k) = hashWithSalt salt k +deriving newtype instance Eq Key +deriving newtype instance Ord Key +deriving newtype instance Hashable Key instance NFData Key where rnf (Key k) = rnf k diff --git a/src/Data/Aeson/KeyMap.hs b/src/Data/Aeson/KeyMap.hs --- a/src/Data/Aeson/KeyMap.hs +++ b/src/Data/Aeson/KeyMap.hs @@ -114,7 +114,6 @@ import Data.Text (Text) import Data.These (These (..)) import Data.Type.Coercion (Coercion (..)) -import Data.Typeable (Typeable) import Text.Read (Read (..), Lexeme(..), readListPrecDefault, prec, lexP, parens) import qualified Data.Aeson.Key as Key @@ -141,7 +140,7 @@ -- | A map from JSON key type 'Key' to 'v'. newtype KeyMap v = KeyMap { unKeyMap :: Map Key v } - deriving (Eq, Ord, Typeable, Data, Functor) + deriving (Eq, Ord, Data, Functor) -- | Construct an empty map. @@ -170,19 +169,8 @@ -- | 'alterF' can be used to insert, delete, or update a value in a map. alterF :: Functor f => (Maybe v -> f (Maybe v)) -> Key -> KeyMap v -> f (KeyMap v) -#if MIN_VERSION_containers(0,5,8) alterF f k = fmap KeyMap . M.alterF f k . unKeyMap -#else -alterF f k m = fmap g (f mv) where - g r = case r of - Nothing -> case mv of - Nothing -> m - Just _ -> delete k m - Just v' -> insert k v' m - mv = lookup k m -#endif - -- | Return the value to which the specified key is mapped, -- or Nothing if this map contains no mapping for the key. lookup :: Key -> KeyMap v -> Maybe v @@ -279,7 +267,7 @@ difference :: KeyMap v -> KeyMap v' -> KeyMap v difference tm1 tm2 = KeyMap (M.difference (unKeyMap tm1) (unKeyMap tm2)) --- The (left-biased) union of two maps. It prefers the first map when duplicate +-- | The (left-biased) union of two maps. It prefers the first map when duplicate -- keys are encountered, i.e. ('union' == 'unionWith' 'const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (M.union x y) @@ -366,7 +354,7 @@ -- | A map from JSON key type 'Key' to 'v'. newtype KeyMap v = KeyMap { unKeyMap :: HashMap Key v } - deriving (Eq, Ord, Typeable, Data, Functor) + deriving (Eq, Ord, Data, Functor) -- | Construct an empty map. empty :: KeyMap v @@ -488,7 +476,7 @@ difference :: KeyMap v -> KeyMap v' -> KeyMap v difference tm1 tm2 = KeyMap (H.difference (unKeyMap tm1) (unKeyMap tm2)) --- The (left-biased) union of two maps. It prefers the first map when duplicate +-- | The (left-biased) union of two maps. It prefers the first map when duplicate -- keys are encountered, i.e. ('union' == 'unionWith' 'const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (H.union x y) @@ -700,6 +688,12 @@ ------------------------------------------------------------------------------- -- semialign ------------------------------------------------------------------------------- + +-- | +-- +-- @since 2.2.5.0 +instance SA.Unzip KeyMap where + unzip = SA.unzipDefault instance SA.Zip KeyMap where zipWith = intersectionWith diff --git a/src/Data/Aeson/Parser.hs b/src/Data/Aeson/Parser.hs deleted file mode 100644 --- a/src/Data/Aeson/Parser.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} --- | --- Module: Data.Aeson.Parser --- Copyright: (c) 2012-2016 Bryan O'Sullivan --- (c) 2011 MailRank, Inc. --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- Efficiently and correctly parse a JSON string. The string must be --- encoded as UTF-8. --- --- It can be useful to think of parsing as occurring in two phases: --- --- * Identification of the textual boundaries of a JSON value. This --- is always strict, so that an invalid JSON document can be --- rejected as soon as possible. --- --- * Conversion of a JSON value to a Haskell value. This may be --- either immediate (strict) or deferred (lazy); see below for --- details. --- --- The question of whether to choose a lazy or strict parser is --- subtle, but it can have significant performance implications, --- resulting in changes in CPU use and memory footprint of 30% to 50%, --- or occasionally more. Measure the performance of your application --- with each! - -module Data.Aeson.Parser - ( - -- * Lazy parsers - -- $lazy - json - , value - , jstring - , scientific - -- ** Handling objects with duplicate keys - , jsonWith - , jsonLast - , jsonAccum - , jsonNoDup - -- * Strict parsers - -- $strict - , json' - , value' - -- ** Handling objects with duplicate keys - , jsonWith' - , jsonLast' - , jsonAccum' - , jsonNoDup' - -- * Decoding without FromJSON instances - , decodeWith - , decodeStrictWith - , eitherDecodeWith - , eitherDecodeStrictWith - ) where - - -import Data.Aeson.Parser.Internal - --- $lazy --- --- The 'json' and 'value' parsers decouple identification from --- conversion. Identification occurs immediately (so that an invalid --- JSON document can be rejected as early as possible), but conversion --- to a Haskell value is deferred until that value is needed. --- --- This decoupling can be time-efficient if only a smallish subset of --- elements in a JSON value need to be inspected, since the cost of --- conversion is zero for uninspected elements. The trade off is an --- increase in memory usage, due to allocation of thunks for values --- that have not yet been converted. - --- $strict --- --- The 'json'' and 'value'' parsers combine identification with --- conversion. They consume more CPU cycles up front, but have a --- smaller memory footprint. diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs deleted file mode 100644 --- a/src/Data/Aeson/Parser/Internal.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -#if __GLASGOW_HASKELL__ <= 800 && __GLASGOW_HASKELL__ >= 706 --- Work around a compiler bug -{-# OPTIONS_GHC -fsimpl-tick-factor=300 #-} -#endif --- | --- Module: Data.Aeson.Parser.Internal --- Copyright: (c) 2011-2016 Bryan O'Sullivan --- (c) 2011 MailRank, Inc. --- License: BSD3 --- Maintainer: Bryan O'Sullivan --- Stability: experimental --- Portability: portable --- --- Efficiently and correctly parse a JSON string. The string must be --- encoded as UTF-8. - -module Data.Aeson.Parser.Internal - ( - -- * Lazy parsers - json, jsonEOF - , jsonWith - , jsonLast - , jsonAccum - , jsonNoDup - , value - , jstring - , jstring_ - , scientific - -- * Strict parsers - , json', jsonEOF' - , jsonWith' - , jsonLast' - , jsonAccum' - , jsonNoDup' - , value' - -- * Helpers - , decodeWith - , decodeStrictWith - , eitherDecodeWith - , eitherDecodeStrictWith - -- ** Handling objects with duplicate keys - , fromListAccum - , parseListNoDup - -- * Text literal unescaping - , unescapeText - ) where - -import Prelude.Compat - -import Control.Applicative ((<|>)) -import Control.Monad (void, when) -import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..), Key) -import qualified Data.Aeson.KeyMap as KM -import qualified Data.Aeson.Key as Key -import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string) -import Data.Function (fix) -import Data.Functor.Compat (($>)) -import Data.Scientific (Scientific) -import Data.Text (Text) -import Data.Vector (Vector) -import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.Lazy as L -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as C -import qualified Data.ByteString.Builder as B -import qualified Data.Scientific as Sci -import Data.Aeson.Parser.Unescape (unescapeText) -import Data.Aeson.Internal.Integer -import Data.Aeson.Internal.Text -import Data.Aeson.Internal.Word8 - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Data.Aeson.Types - -------------------------------------------------------------------------------- --- Parsers -------------------------------------------------------------------------------- - --- | Parse any JSON value. --- --- The conversion of a parsed value to a Haskell value is deferred --- until the Haskell value is needed. This may improve performance if --- only a subset of the results of conversions are needed, but at a --- cost in thunk allocation. --- --- This function is an alias for 'value'. In aeson 0.8 and earlier, it --- parsed only object or array types, in conformance with the --- now-obsolete RFC 4627. --- --- ==== Warning --- --- If an object contains duplicate keys, only the first one will be kept. --- For a more flexible alternative, see 'jsonWith'. -json :: Parser Value -json = value - --- | Parse any JSON value. --- --- This is a strict version of 'json' which avoids building up thunks --- during parsing; it performs all conversions immediately. Prefer --- this version if most of the JSON data needs to be accessed. --- --- This function is an alias for 'value''. In aeson 0.8 and earlier, it --- parsed only object or array types, in conformance with the --- now-obsolete RFC 4627. --- --- ==== Warning --- --- If an object contains duplicate keys, only the first one will be kept. --- For a more flexible alternative, see 'jsonWith''. -json' :: Parser Value -json' = value' - --- Open recursion: object_, object_', array_, array_' are parameterized by the --- toplevel Value parser to be called recursively, to keep the parameter --- mkObject outside of the recursive loop for proper inlining. - -object_ :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value -object_ mkObject val = Object <$> objectValues mkObject key val -{-# INLINE object_ #-} - -object_' :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value -object_' mkObject val' = do - !vals <- objectValues mkObject key' val' - return (Object vals) - where - key' = do - !s <- key - return s -{-# INLINE object_' #-} - -objectValues :: ([(Key, Value)] -> Either String Object) - -> Parser Key -> Parser Value -> Parser (KM.KeyMap Value) -objectValues mkObject str val = do - skipSpace - w <- A.peekWord8' - if w == W8_CLOSE_CURLY - then A.anyWord8 >> return KM.empty - else loop [] - where - -- Why use acc pattern here, you may ask? because then the underlying 'KM.fromList' - -- implementation can make use of mutation when constructing a map. For example, - -- 'HashMap` uses 'unsafeInsert' and it's much faster because it's doing in place - -- update to the 'HashMap'! - loop acc = do - k <- (str A. "object key") <* skipSpace <* (char ':' A. "':'") - v <- (val A. "object value") <* skipSpace - ch <- A.satisfy (\w -> w == W8_COMMA || w == W8_CLOSE_CURLY) A. "',' or '}'" - let acc' = (k, v) : acc - if ch == W8_COMMA - then skipSpace >> loop acc' - else case mkObject acc' of - Left err -> fail err - Right obj -> pure obj -{-# INLINE objectValues #-} - -array_ :: Parser Value -> Parser Value -array_ val = Array <$> arrayValues val -{-# INLINE array_ #-} - -array_' :: Parser Value -> Parser Value -array_' val = do - !vals <- arrayValues val - return (Array vals) -{-# INLINE array_' #-} - -arrayValues :: Parser Value -> Parser (Vector Value) -arrayValues val = do - skipSpace - w <- A.peekWord8' - if w == W8_CLOSE_SQUARE - then A.anyWord8 >> return Vector.empty - else loop [] 1 - where - loop acc !len = do - v <- (val A. "json list value") <* skipSpace - ch <- A.satisfy (\w -> w == W8_COMMA || w == W8_CLOSE_SQUARE) A. "',' or ']'" - if ch == W8_COMMA - then skipSpace >> loop (v:acc) (len+1) - else return (Vector.reverse (Vector.fromListN len (v:acc))) -{-# INLINE arrayValues #-} - --- | Parse any JSON value. Synonym of 'json'. -value :: Parser Value -value = jsonWith (pure . KM.fromList) - --- | Parse any JSON value. --- --- This parser is parameterized by a function to construct an 'Object' --- from a raw list of key-value pairs, where duplicates are preserved. --- The pairs appear in __reverse order__ from the source. --- --- ==== __Examples__ --- --- 'json' keeps only the first occurrence of each key, using 'Data.Aeson.KeyMap.fromList'. --- --- @ --- 'json' = 'jsonWith' ('Right' '.' 'H.fromList') --- @ --- --- 'jsonLast' keeps the last occurrence of each key, using --- @'HashMap.Lazy.fromListWith' ('const' 'id')@. --- --- @ --- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id')) --- @ --- --- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using --- 'fromListAccum'. --- --- @ --- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum') --- @ --- --- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'. --- --- @ --- 'jsonNoDup' = 'jsonWith' 'parseListNoDup' --- @ -jsonWith :: ([(Key, Value)] -> Either String Object) -> Parser Value -jsonWith mkObject = fix $ \value_ -> do - skipSpace - w <- A.peekWord8' - case w of - W8_DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_) - W8_OPEN_CURLY -> A.anyWord8 *> object_ mkObject value_ - W8_OPEN_SQUARE -> A.anyWord8 *> array_ value_ - W8_f -> string "false" $> Bool False - W8_t -> string "true" $> Bool True - W8_n -> string "null" $> Null - _ | w >= W8_0 && w <= W8_9 || w == W8_MINUS - -> Number <$> scientific - | otherwise -> fail "not a valid json value" -{-# INLINE jsonWith #-} - --- | Variant of 'json' which keeps only the last occurrence of every key. -jsonLast :: Parser Value -jsonLast = jsonWith (Right . KM.fromListWith (const id)) - --- | Variant of 'json' wrapping all object mappings in 'Array' to preserve --- key-value pairs with the same keys. -jsonAccum :: Parser Value -jsonAccum = jsonWith (Right . fromListAccum) - --- | Variant of 'json' which fails if any object contains duplicate keys. -jsonNoDup :: Parser Value -jsonNoDup = jsonWith parseListNoDup - --- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all --- associated values from the original list @kvs@. --- --- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)] --- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])] -fromListAccum :: [(Key, Value)] -> Object -fromListAccum = - fmap (Array . Vector.fromList . ($ [])) . KM.fromListWith (.) . (fmap . fmap) (:) - --- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys. -parseListNoDup :: [(Key, Value)] -> Either String Object -parseListNoDup = - KM.traverseWithKey unwrap . KM.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just - where - - unwrap k Nothing = Left $ "found duplicate key: " ++ show k - unwrap _ (Just v) = Right v - --- | Strict version of 'value'. Synonym of 'json''. -value' :: Parser Value -value' = jsonWith' (pure . KM.fromList) - --- | Strict version of 'jsonWith'. -jsonWith' :: ([(Key, Value)] -> Either String Object) -> Parser Value -jsonWith' mkObject = fix $ \value_ -> do - skipSpace - w <- A.peekWord8' - case w of - W8_DOUBLE_QUOTE -> do - !s <- A.anyWord8 *> jstring_ - return (String s) - W8_OPEN_CURLY -> A.anyWord8 *> object_' mkObject value_ - W8_OPEN_SQUARE -> A.anyWord8 *> array_' value_ - W8_f -> string "false" $> Bool False - W8_t -> string "true" $> Bool True - W8_n -> string "null" $> Null - _ | w >= W8_0 && w <= W8_9 || w == W8_MINUS - -> do - !n <- scientific - return (Number n) - | otherwise -> fail "not a valid json value" -{-# INLINE jsonWith' #-} - --- | Variant of 'json'' which keeps only the last occurrence of every key. -jsonLast' :: Parser Value -jsonLast' = jsonWith' (pure . KM.fromListWith (const id)) - --- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve --- key-value pairs with the same keys. -jsonAccum' :: Parser Value -jsonAccum' = jsonWith' (pure . fromListAccum) - --- | Variant of 'json'' which fails if any object contains duplicate keys. -jsonNoDup' :: Parser Value -jsonNoDup' = jsonWith' parseListNoDup - --- | Parse a quoted JSON string. -jstring :: Parser Text -jstring = A.word8 W8_DOUBLE_QUOTE *> jstring_ - --- | Parse a JSON Key -key :: Parser Key -key = Key.fromText <$> jstring - --- | Parse a string without a leading quote. -jstring_ :: Parser Text -{-# INLINE jstring_ #-} -jstring_ = do - s <- A.takeWhile (\w -> w /= W8_DOUBLE_QUOTE && w /= W8_BACKSLASH && w >= 0x20 && w < 0x80) - mw <- A.peekWord8 - case mw of - Nothing -> fail "string without end" - Just W8_DOUBLE_QUOTE -> A.anyWord8 $> unsafeDecodeASCII s - Just w | w < 0x20 -> fail "unescaped control character" - _ -> jstringSlow s - -jstringSlow :: B.ByteString -> Parser Text -{-# INLINE jstringSlow #-} -jstringSlow s' = do - s <- A.scan startState go <* A.anyWord8 - case unescapeText (B.append s' s) of - Right r -> return r - Left err -> fail $ show err - where - startState = False - go a c - | a = Just False - | c == W8_DOUBLE_QUOTE = Nothing - | otherwise = let a' = c == W8_BACKSLASH - in Just a' - -decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a -decodeWith p to s = - case L.parse p s of - L.Done _ v -> case to v of - Success a -> Just a - _ -> Nothing - _ -> Nothing -{-# INLINE decodeWith #-} - -decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString - -> Maybe a -decodeStrictWith p to s = - case either Error to (A.parseOnly p s) of - Success a -> Just a - _ -> Nothing -{-# INLINE decodeStrictWith #-} - -eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString - -> Either (JSONPath, String) a -eitherDecodeWith p to s = - case L.parse p s of - L.Done _ v -> case to v of - ISuccess a -> Right a - IError path msg -> Left (path, msg) - L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg) - where - buildMsg :: L.ByteString -> [String] -> String -> String - buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed - buildMsg notYetParsed (expectation:_) msg = - msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed -{-# INLINE eitherDecodeWith #-} - --- | Grab the first 100 bytes from the non parsed portion and --- format to get nicer error messages -formatErrorLine :: L.ByteString -> String -formatErrorLine bs = - C.unpack . - -- if formatting results in empty ByteString just return that - -- otherwise construct the error message with the bytestring builder - (\bs' -> - if BSL.null bs' - then BSL.empty - else - B.toLazyByteString $ - B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'" - ) . - -- if newline is present cut at that position - BSL.takeWhile (10 /=) . - -- remove spaces, CR's, tabs, backslashes and quotes characters - BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) . - -- take 100 bytes - BSL.take 100 $ bs - -eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString - -> Either (JSONPath, String) a -eitherDecodeStrictWith p to s = - case either (IError []) to (A.parseOnly p s) of - ISuccess a -> Right a - IError path msg -> Left (path, msg) -{-# INLINE eitherDecodeStrictWith #-} - --- $lazy --- --- The 'json' and 'value' parsers decouple identification from --- conversion. Identification occurs immediately (so that an invalid --- JSON document can be rejected as early as possible), but conversion --- to a Haskell value is deferred until that value is needed. --- --- This decoupling can be time-efficient if only a smallish subset of --- elements in a JSON value need to be inspected, since the cost of --- conversion is zero for uninspected elements. The trade off is an --- increase in memory usage, due to allocation of thunks for values --- that have not yet been converted. - --- $strict --- --- The 'json'' and 'value'' parsers combine identification with --- conversion. They consume more CPU cycles up front, but have a --- smaller memory footprint. - --- | Parse a top-level JSON value followed by optional whitespace and --- end-of-input. See also: 'json'. -jsonEOF :: Parser Value -jsonEOF = json <* skipSpace <* endOfInput - --- | Parse a top-level JSON value followed by optional whitespace and --- end-of-input. See also: 'json''. -jsonEOF' :: Parser Value -jsonEOF' = json' <* skipSpace <* endOfInput - --- | The only valid whitespace in a JSON document is space, newline, --- carriage return, and tab. -skipSpace :: Parser () -skipSpace = A.skipWhile $ \w -> w == W8_SPACE || w == W8_NL || w == W8_CR || w == W8_TAB -{-# INLINE skipSpace #-} - ------------------- Copy-pasted and adapted from attoparsec ------------------ - --- A strict pair -data SP = SP !Integer {-# UNPACK #-}!Int - -decimal0 :: Parser Integer -decimal0 = do - digits <- A.takeWhile1 isDigit_w8 - if B.length digits > 1 && B.unsafeHead digits == W8_0 - then fail "leading zero" - else return (bsToInteger digits) - --- | Parse a JSON number. -scientific :: Parser Scientific -scientific = do - sign <- A.peekWord8' - let !positive = not (sign == W8_MINUS) - when (sign == W8_PLUS || sign == W8_MINUS) $ - void A.anyWord8 - - n <- decimal0 - - let f fracDigits = SP (B.foldl' step n fracDigits) - (negate $ B.length fracDigits) - step a w = a * 10 + fromIntegral (w - W8_0) - - dotty <- A.peekWord8 - SP c e <- case dotty of - Just W8_DOT -> A.anyWord8 *> (f <$> A.takeWhile1 isDigit_w8) - _ -> pure (SP n 0) - - let !signedCoeff | positive = c - | otherwise = -c - - (A.satisfy (\ex -> case ex of W8_e -> True; W8_E -> True; _ -> False) *> - fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|> - return (Sci.scientific signedCoeff e) -{-# INLINE scientific #-} diff --git a/src/Data/Aeson/Parser/Time.hs b/src/Data/Aeson/Parser/Time.hs --- a/src/Data/Aeson/Parser/Time.hs +++ b/src/Data/Aeson/Parser/Time.hs @@ -1,89 +1,25 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Aeson.Parser.Time - ( - run - , day - , month - , quarter - , localTime - , timeOfDay - , timeZone - , utcTime - , zonedTime - ) where - -import Prelude.Compat +module Data.Aeson.Parser.Time ( + run, + FT.parseDay, + FT.parseMonth, + FT.parseQuarter, + FT.parseQuarterOfYear, + FT.parseLocalTime, + FT.parseTimeOfDay, + FT.parseUTCTime, + FT.parseZonedTime, +) where -import Data.Attoparsec.Text (Parser) import Data.Text (Text) -import Data.Time.Calendar (Day) -import Data.Time.Calendar.Quarter.Compat (Quarter) -import Data.Time.Calendar.Month.Compat (Month) -import Data.Time.Clock (UTCTime(..)) -import qualified Data.Aeson.Types.Internal as Aeson -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 <* 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 = T.day -{-# INLINE day #-} - --- | Parse a date of the form @[+,-]YYYY-MM@. -month :: Parser Month -month = T.month -{-# INLINE month #-} - --- | Parse a date of the form @[+,-]YYYY-QN@. -quarter :: Parser Quarter -quarter = T.quarter -{-# INLINE quarter #-} - --- | Parse a time of the form @HH:MM[:SS[.SSS]]@. -timeOfDay :: Parser Local.TimeOfDay -timeOfDay = T.timeOfDay -{-# INLINE timeOfDay #-} - --- | Parse a quarter of the form @[+,-]YYYY-QN@. - --- | 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 = 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 = T.localTime -{-# INLINE localTime #-} +import qualified Data.Aeson.Types.Internal as Aeson +import qualified Data.Time.FromText as FT --- | Behaves as 'zonedTime', but converts any time zone offset into a --- UTC time. -utcTime :: Parser UTCTime -utcTime = T.utcTime -{-# INLINE utcTime #-} +type Parser a = Text -> Either String a --- | 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 = T.zonedTime -{-# INLINE zonedTime #-} +-- | Run a @text-iso8601@ parser as an aeson parser. +run :: Parser a -> Text -> Aeson.Parser a +run f t = case f t of + Left err -> fail $ "could not parse date: " ++ err + Right r -> return r +{-# INLINE run #-} diff --git a/src/Data/Aeson/Parser/Unescape.hs b/src/Data/Aeson/Parser/Unescape.hs deleted file mode 100644 --- a/src/Data/Aeson/Parser/Unescape.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Aeson.Parser.Unescape - ( - unescapeText - ) where - -#ifdef CFFI -import Data.Aeson.Parser.UnescapeFFI (unescapeText) -#else -import Data.Aeson.Parser.UnescapePure (unescapeText) -#endif diff --git a/src/Data/Aeson/QQ/Simple.hs b/src/Data/Aeson/QQ/Simple.hs --- a/src/Data/Aeson/QQ/Simple.hs +++ b/src/Data/Aeson/QQ/Simple.hs @@ -7,9 +7,6 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax (Lift (..)) -import Prelude () -import Prelude.Compat - -- | Converts a string representation of a JSON value into 'Data.Aeson.Value' at compile-time. -- diff --git a/src/Data/Aeson/RFC8785.hs b/src/Data/Aeson/RFC8785.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/RFC8785.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE UnboxedTuples, BangPatterns #-} +-- | JSON Canonicalization Scheme https://datatracker.ietf.org/doc/html/rfc8785 +module Data.Aeson.RFC8785 ( + encodeCanonical, +) where + +import Data.List (sortBy) +import Data.Ord (comparing) +import GHC.Integer (quotRemInteger) +import Math.NumberTheory.Logarithms (integerLog10) + +import Data.Aeson +import Data.Aeson.Encoding +import Data.Aeson.Encoding.Internal +import Data.Aeson.Internal.Prelude + +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Scientific as Sci +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Data.Word8.Patterns as W8 + +-- $setup +-- >>> import Data.Aeson + +-- | Encode to JSON according to RFC 8785 canonicalization scheme. +-- https://datatracker.ietf.org/doc/html/rfc8785 +-- +-- 'encodeCanonical' uses 'toJSON' to produce intermediate 'Value', +-- as 'toEncoding' may (and most likely) produces non-canonical JSON. +-- +-- Note: @decode (encodeCanonical v) === Just v@ for all @v :: Value@, +-- i.e. 'encodeCanonical' doesn't lose any information. +-- +-- However, the example in RFC8785 /loses/ information as the intermediate +-- number representation is 'Double', also current @toJSON :: Double -> Value@ +-- sometimes produces too precise values. For example +-- +-- >>> toJSON (1e23 :: Double) +-- Number 9.999999999999999e22 +-- +-- 'show' also behaves the same: +-- +-- >>> 1e23 :: Double +-- 9.999999999999999e22 +-- +-- Note: RFC8785 is __not the same scheme__ as used in +-- [canonical-json](https://hackage.haskell.org/package/canonical-json) package +-- (https://wiki.laptop.org/go/Canonical_JSON). +-- That scheme produces /invalid/ JSON (e.g. control characters encoded as is, not escaped) +-- and cannot encode non-integral numbers. +-- +-- @since 2.2.1.0 +-- +encodeCanonical :: ToJSON a => a -> LBS.ByteString +encodeCanonical = encodingToLazyByteString . toCanonical . toJSON + +toCanonical :: Value -> Encoding +toCanonical Null = null_ +toCanonical (Bool b) = bool b +toCanonical (Number n) = canonicalNumber n +toCanonical (String s) = canonicalString s +toCanonical (Array v) = list toCanonical (V.toList v) +toCanonical (Object m) = dict (canonicalString . Key.toText) toCanonical ifr $ + sortBy (\(k1, _) (k2, _) -> propertyCmp k1 k2) (KM.toList m) + +ifr :: (k -> v -> a -> a) -> a -> [(k, v)] -> a +ifr f z = foldr (\(k, v) -> f k v) z +{-# INLINE ifr #-} + +-- Property name strings to be sorted are formatted as arrays of UTF-16 code units. +propertyCmp :: Key -> Key -> Ordering +propertyCmp = comparing f where + -- this is slow implementation, but it's obviously not wrong. + f :: Key -> BS.ByteString + f = TE.encodeUtf16BE . Key.toText + +-- strings are already serialized canonically. +canonicalString :: Text -> Encoding' a +canonicalString = text + +-- RFC 8785 is outsourcing number format to ECMA-262. +-- 10th edition, 7.1.12.1 NumberToString +-- https://262.ecma-international.org/10.0/#sec-tostring-applied-to-the-number-type +-- +-- Note: this specification is not lossy +-- Given 'Scientific' we can choose n,k,s uniquely: 'nks'. +-- +-- RFC8785 Appendix D says "don't use bignums". +canonicalNumber :: Scientific -> Encoding +canonicalNumber m = case compare m 0 of + EQ -> Encoding (B.word8 W8.DIGIT_0) + LT -> Encoding (B.word8 W8.HYPHEN <> fromEncoding (canonicalNumber' (negate m))) + GT -> canonicalNumber' m + +-- input: Positive number +canonicalNumber' :: Scientific -> Encoding +canonicalNumber' m + | k <= n, n <= 21 + = Encoding $ + BP.primMapListFixed BP.word8 ds <> + BP.primMapListFixed BP.word8 (replicate (n - k) W8.DIGIT_0) + + | 0 < n, n <= 21 + , let (pfx, sfx) = splitAt n ds + = Encoding $ + BP.primMapListFixed BP.word8 pfx <> + B.word8 W8.PERIOD <> + BP.primMapListFixed BP.word8 sfx + + | -6 < n, n <= 0 + = Encoding $ + B.word8 W8.DIGIT_0 <> + B.word8 W8.PERIOD <> + BP.primMapListFixed BP.word8 (replicate (negate n) W8.DIGIT_0) <> + BP.primMapListFixed BP.word8 ds + + | k == 1, [d] <- ds + = Encoding $ + B.word8 d <> + B.word8 W8.LOWER_E <> + B.word8 (if (n - 1) >= 0 then W8.PLUS else W8.HYPHEN) <> + BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1))) + + | (d:ds') <- ds + = Encoding $ + B.word8 d <> + B.word8 W8.PERIOD <> + BP.primMapListFixed BP.word8 ds' <> + B.word8 W8.LOWER_E <> + B.word8 (if (n - 1) >= 0 then W8.PLUS else W8.HYPHEN) <> + BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1))) + + | otherwise + = string "0" -- shouldn't happen, but we need a default case. + + where + -- 5. Otherwise, let n, k, and s be integers such that + -- k ≥ 1, 10k - 1 ≤ s < 10k, the Number value for s × 10n - k is m, + -- and k is as small as possible. + -- Note that k is the number of digits in the decimal representation of s, + -- that s is not divisible by 10, and that the least significant digit of s + -- is not necessarily uniquely determined by these criteria. + (n, k, s) = nks m + ds = integerToDecimalDigits s + +-- 5. Otherwise, let n, k, and s be integers such that k ≥ 1, 10^(k - 1) ≤ s < 10^k, +-- the Number value for s × 10^(n - k) is m, and k is as small as possible. +-- Note that k is the number of digits in the decimal representation of s, +-- that s is not divisible by 10, and that the least significant digit of s +-- is not necessarily uniquely determined by these criteria. +nks :: Scientific -> (Int, Int, Integer) +nks m = (e + k, k, c) + where + m' = Sci.normalize m + c = Sci.coefficient m' + e = Sci.base10Exponent m' + k = integerLog10 c + 1 + +integerToDecimalDigits :: Integer -> [Word8] +integerToDecimalDigits = go [] where + go acc 0 = acc + go acc i = case quotRemInteger i 10 of + (# q, r #) -> go (d:acc) q where !d = fromIntegral r + W8.DIGIT_0 diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -3,7 +3,6 @@ {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskellQuotes #-} @@ -111,45 +110,30 @@ , mkLiftParseJSON2 ) where -import Prelude.Compat hiding (fail) - -- We don't have MonadFail Q, so we should use `fail` from real `Prelude` -import Prelude (fail) -import Control.Applicative ((<|>)) +import Data.Aeson.Internal.Prelude + import Data.Char (ord) import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject) import Data.Aeson.Types.Internal ((), JSONPathElement(Key)) -import Data.Aeson.Types.FromJSON (parseOptionalFieldWith) import Data.Aeson.Types.ToJSON (fromPairs, pair) import Data.Aeson.Key (Key) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM -import Control.Monad (liftM2, unless, when) import Data.Foldable (foldr') -#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0) -import Data.List (nub) -#endif -import Data.List (foldl', genericLength, intercalate, partition, union) +import Data.List (genericLength, intercalate, union) import Data.List.NonEmpty ((<|), NonEmpty((:|))) import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Monoid as Monoid import Data.Set (Set) import Language.Haskell.TH hiding (Arity) -import Language.Haskell.TH.Datatype as Datatype -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Language.Haskell.TH.Syntax (mkNameG_tc) -#endif +import Language.Haskell.TH.Datatype import Text.Printf (printf) import qualified Data.Aeson.Encoding.Internal as E -import qualified Data.Foldable as F (all) import qualified Data.List.NonEmpty as NE (length, reverse) import qualified Data.Map as M (fromList, keys, lookup , singleton, size) -#if !MIN_VERSION_base(4,16,0) -import qualified Data.Semigroup as Semigroup (Option(..)) -#endif import qualified Data.Set as Set (empty, insert, member) import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V (unsafeIndex, null, length, create, empty) @@ -336,10 +320,11 @@ consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do value <- newName "value" + os <- newNameList "_o" $ arityInt jc tjs <- newNameList "_tj" $ arityInt jc tjls <- newNameList "_tjl" $ arityInt jc - let zippedTJs = zip tjs tjls - interleavedTJs = interleave tjs tjls + let zippedTJs = zip3 os tjs tjls + interleavedTJs = flatten3 zippedTJs lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys tvMap = M.fromList $ zip lastTyVars zippedTJs lamE (map varP $ interleavedTJs ++ [value]) $ @@ -468,40 +453,26 @@ (True,True,[_]) -> argsToValue letInsert target jc tvMap opts multiCons (info{constructorVariant = NormalConstructor}) _ -> do + argTys' <- mapM resolveTypeSynonyms argTys args <- newNameList "arg" $ length argTys' - let pairs | omitNothingFields opts = infixApp maybeFields - [|(Monoid.<>)|] - restFields - | otherwise = mconcatE (map pureToPair argCons) - - argCons = zip3 (map varE args) argTys' fields - - maybeFields = mconcatE (map maybeToPair maybes) + let argCons = zip3 (map varE args) argTys' fields - restFields = mconcatE (map pureToPair rest) + toPair (arg, argTy, fld) = + let fieldName = fieldLabel opts fld + toValue = dispatchToJSON target jc conName tvMap argTy - (maybes0, rest0) = partition isMaybe argCons -#if MIN_VERSION_base(4,16,0) - maybes = maybes0 - rest = rest0 -#else - (options, rest) = partition isOption rest0 - maybes = maybes0 ++ map optionToMaybe options -#endif + omitFn :: Q Exp + omitFn + | omitNothingFields opts = dispatchOmitField jc conName tvMap argTy + | otherwise = [| const False |] - maybeToPair = toPairLifted True - pureToPair = toPairLifted False + in condE + (omitFn `appE` arg) + [| mempty |] + (pairE letInsert target fieldName (toValue `appE` arg)) - toPairLifted lifted (arg, argTy, field) = - let toValue = dispatchToJSON target jc conName tvMap argTy - fieldName = fieldLabel opts field - e arg' = pairE letInsert target fieldName (toValue `appE` arg') - in if lifted - then do - x <- newName "x" - [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg - else e arg + pairs = mconcatE (map toPair argCons) match (conP conName $ map varP args) (normalB $ recordSumToValue letInsert target opts multiCons (null argTys) conName pairs) @@ -526,19 +497,6 @@ ) [] -isMaybe :: (a, Type, b) -> Bool -isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe -isMaybe _ = False - -#if !MIN_VERSION_base(4,16,0) -isOption :: (a, Type, b) -> Bool -isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option -isOption _ = False - -optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c) -optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c) -#endif - (<^>) :: ExpQ -> ExpQ -> ExpQ (<^>) a b = infixApp a [|(E.><)|] b infixr 6 <^> @@ -697,10 +655,11 @@ consFromJSON jc tName opts instTys cons = do value <- newName "value" + os <- newNameList "_o" $ arityInt jc pjs <- newNameList "_pj" $ arityInt jc pjls <- newNameList "_pjl" $ arityInt jc - let zippedPJs = zip pjs pjls - interleavedPJs = interleave pjs pjls + let zippedPJs = zip3 os pjs pjls + interleavedPJs = flatten3 zippedPJs lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys tvMap = M.fromList $ zip lastTyVars zippedPJs lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap @@ -965,6 +924,11 @@ (infixApp (conE conName) [|(<$>)|] x) xs where + lookupField :: Type -> Q Exp + lookupField argTy + | allowOmittedFields opts = [| lookupFieldOmit |] `appE` dispatchOmittedField jc conName tvMap argTy + | otherwise = [| lookupFieldNoOmit |] + tagFieldNameAppender = if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id knownFields = appE [|KM.fromList|] $ listE $ @@ -981,7 +945,7 @@ (appE [|show|] (varE unknownFields))) [] ] - x:xs = [ [|lookupField|] + (x,xs) = nonEmpty [ lookupField argTy `appE` dispatchParseJSON jc conName tvMap argTy `appE` litE (stringL $ show tName) `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName) @@ -991,6 +955,11 @@ | (field, argTy) <- zip fields argTys ] +-- A hack, as I'm too lazy to change code to not assume fields are non empty. +nonEmpty :: [a] -> (a, [a]) +nonEmpty (x:xs) = (x,xs) +nonEmpty [] = error "unexpected empty list" + getValField :: Name -> String -> [MatchQ] -> Q Exp getValField obj valFieldName matches = do val <- newName "val" @@ -1092,12 +1061,12 @@ -> [Type] -- ^ The argument types of the constructor. -> Name -- ^ Name of the type to which the constructor belongs. -> Name -- ^ 'Con'structor name. - -> Integer -- ^ 'Con'structor arity. + -> Integer -- ^ 'Con'structor arity. >= 1 -> [Q Match] parseProduct jc tvMap argTys tName conName numArgs = [ do arr <- newName "arr" -- List of: "parseJSON (arr `V.unsafeIndex` )" - let x:xs = [ dispatchParseJSON jc conName tvMap argTy + let (x,xs) = nonEmpty [ dispatchParseJSON jc conName tvMap argTy `appE` infixApp (varE arr) [|V.unsafeIndex|] @@ -1149,26 +1118,17 @@ , actual ] -class LookupField a where - lookupField :: (Value -> Parser a) -> String -> String - -> Object -> Key -> Parser a - -instance {-# OVERLAPPABLE #-} LookupField a where - lookupField = lookupFieldWith - -instance {-# INCOHERENT #-} LookupField (Maybe a) where - lookupField pj _ _ = parseOptionalFieldWith pj - -#if !MIN_VERSION_base(4,16,0) -instance {-# INCOHERENT #-} LookupField (Semigroup.Option a) where - lookupField pj tName rec obj key = - fmap Semigroup.Option - (lookupField (fmap Semigroup.getOption . pj) tName rec obj key) -#endif +lookupFieldOmit :: Maybe a -> (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a +lookupFieldOmit maybeDefault pj tName rec obj key = + case KM.lookup key obj of + Nothing -> + case maybeDefault of + Nothing -> unknownFieldFail tName rec (Key.toString key) + Just x -> pure x + Just v -> pj v Key key -lookupFieldWith :: (Value -> Parser a) -> String -> String - -> Object -> Key -> Parser a -lookupFieldWith pj tName rec obj key = +lookupFieldNoOmit :: (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a +lookupFieldNoOmit pj tName rec obj key = case KM.lookup key obj of Nothing -> unknownFieldFail tName rec (Key.toString key) Just v -> pj v Key key @@ -1257,11 +1217,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTys -#else - , datatypeVars = instTys -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -1293,11 +1249,7 @@ case info of DatatypeInfo { datatypeContext = ctxt , datatypeName = parentName -#if MIN_VERSION_th_abstraction(0,3,0) , datatypeInstTypes = instTys -#else - , datatypeVars = instTys -#endif , datatypeVariant = variant , datatypeCons = cons } -> do @@ -1307,20 +1259,26 @@ !_ <- buildTypeInstance parentName jc ctxt instTys variant consFun jc parentName opts instTys cons +data FunArg = Omit | Single | Plural deriving (Eq) + dispatchFunByType :: JSONClass -> JSONFun -> Name -> TyVarMap - -> Bool -- True if we are using the function argument that works - -- on lists (e.g., [a] -> Value). False is we are using - -- the function argument that works on single values - -- (e.g., a -> Value). + -> FunArg -- Plural if we are using the function argument that works + -- on lists (e.g., [a] -> Value). Single is we are using + -- the function argument that works on single values + -- (e.g., a -> Value). Omit if we use it to check omission + -- (e.g. a -> Bool) -> Type -> Q Exp dispatchFunByType _ jf _ tvMap list (VarT tyName) = varE $ case M.lookup tyName tvMap of - Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp - Nothing -> jsonFunValOrListName list jf Arity0 + Just (tfjoExp, tfjExp, tfjlExp) -> case list of + Omit -> tfjoExp + Single -> tfjExp + Plural -> tfjlExp + Nothing -> jsonFunValOrListName list jf Arity0 dispatchFunByType jc jf conName tvMap list (SigT ty _) = dispatchFunByType jc jf conName tvMap list ty dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) = @@ -1339,25 +1297,30 @@ tyVarNames :: [Name] tyVarNames = M.keys tvMap + args :: [Q Exp] + args + | list == Omit = map (dispatchFunByType jc jf conName tvMap Omit) rhsArgs + | otherwise = zipWith (dispatchFunByType jc jf conName tvMap) (cycle [Omit,Single,Plural]) (triple rhsArgs) + itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs if any (`mentionsName` tyVarNames) lhsArgs || itf then outOfPlaceTyVarError jc conName else if any (`mentionsName` tyVarNames) rhsArgs - then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) - : zipWith (dispatchFunByType jc jf conName tvMap) - (cycle [False,True]) - (interleave rhsArgs rhsArgs) + then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) : args else varE $ jsonFunValOrListName list jf Arity0 -dispatchToJSON - :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp -dispatchToJSON target jc n tvMap = - dispatchFunByType jc (targetToJSONFun target) n tvMap False +dispatchToJSON :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp +dispatchToJSON target jc n tvMap = dispatchFunByType jc (targetToJSONFun target) n tvMap Single -dispatchParseJSON - :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp -dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False +dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp +dispatchOmitField jc n tvMap = dispatchFunByType jc ToJSON n tvMap Omit +dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp +dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Single + +dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp +dispatchOmittedField jc n tvMap = dispatchFunByType jc ParseJSON n tvMap Omit + -------------------------------------------------------------------------------- -- Utility functions -------------------------------------------------------------------------------- @@ -1456,9 +1419,7 @@ Newtype -> False DataInstance -> True NewtypeInstance -> True -#if MIN_VERSION_th_abstraction(0,5,0) - Datatype.TypeData -> False -#endif + Language.Haskell.TH.Datatype.TypeData -> False remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation @@ -1629,13 +1590,14 @@ -- A mapping of type variable Names to their encoding/decoding function Names. -- For example, in a ToJSON2 declaration, a TyVarMap might look like -- --- { a ~> (tj1, tjl1) --- , b ~> (tj2, tjl2) } +-- { a ~> (o1, tj1, tjl1) +-- , b ~> (o2, tj2, tjl2) } -- --- where a and b are the last two type variables of the datatype, tj1 and tjl1 are --- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2 --- are the function arguments of types (b -> Value) and ([b] -> Value). -type TyVarMap = Map Name (Name, Name) +-- where a and b are the last two type variables of the datatype, +-- o1 and o2 are function argument of types (a -> Bool), +-- tj1 and tjl1 are the function arguments of types (a -> Value) +-- and ([a] -> Value), and tj2 and tjl2 are the function arguments of types (b -> Value) and ([b] -> Value). +type TyVarMap = Map Name (Name, Name, Name) -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool @@ -1659,7 +1621,7 @@ hasKindVarChain :: Int -> Type -> Maybe [Name] hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) - in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk + in if (NE.length uk - 1 == kindArrows) && all isStarOrVar uk then Just (concatMap freeVariables uk) else Nothing @@ -1680,10 +1642,12 @@ varTToName :: Type -> Name varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe -interleave :: [a] -> [a] -> [a] -interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s -interleave _ _ = [] +flatten3 :: [(a,a,a)] -> [a] +flatten3 = foldr (\(a,b,c) xs -> a:b:c:xs) [] +triple :: [a] -> [a] +triple = foldr (\x xs -> x:x:x:xs) [] + -- | Fully applies a type constructor to its type variables. applyTyCon :: Name -> [Type] -> Type applyTyCon = foldl' AppT . ConT @@ -1714,17 +1678,10 @@ go tcName = do info <- reify tcName case info of -#if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> withinFirstArgs bndrs FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> withinFirstArgs bndrs -#else - FamilyI (FamilyD TypeFam _ bndrs _) _ - -> withinFirstArgs bndrs - FamilyI (ClosedTypeFamilyD _ bndrs _ _) _ - -> withinFirstArgs bndrs -#endif _ -> return False where withinFirstArgs :: [a] -> Q Bool @@ -1763,12 +1720,7 @@ -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool -#if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName -#else -predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys -predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names -#endif -- | Split an applied type into its individual components. For example, this: -- @@ -1846,12 +1798,7 @@ valueConName Null = "Null" applyCon :: Name -> Name -> Pred -applyCon con t = -#if MIN_VERSION_template_haskell(2,10,0) - AppT (ConT con) (VarT t) -#else - ClassP con [VarT t] -#endif +applyCon con t = AppT (ConT con) (VarT t) -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: @@ -1990,6 +1937,17 @@ jsonClassName (JSONClass From Arity1) = ''FromJSON1 jsonClassName (JSONClass From Arity2) = ''FromJSON2 +jsonFunOmitName :: JSONFun -> Arity -> Name +jsonFunOmitName ToJSON Arity0 = 'omitField +jsonFunOmitName ToJSON Arity1 = 'liftOmitField +jsonFunOmitName ToJSON Arity2 = 'liftOmitField2 +jsonFunOmitName ToEncoding Arity0 = 'omitField +jsonFunOmitName ToEncoding Arity1 = 'liftOmitField +jsonFunOmitName ToEncoding Arity2 = 'liftOmitField2 +jsonFunOmitName ParseJSON Arity0 = 'omittedField +jsonFunOmitName ParseJSON Arity1 = 'liftOmittedField +jsonFunOmitName ParseJSON Arity2 = 'liftOmittedField2 + jsonFunValName :: JSONFun -> Arity -> Name jsonFunValName ToJSON Arity0 = 'toJSON jsonFunValName ToJSON Arity1 = 'liftToJSON @@ -2012,10 +1970,11 @@ jsonFunListName ParseJSON Arity1 = 'liftParseJSONList jsonFunListName ParseJSON Arity2 = 'liftParseJSONList2 -jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False +jsonFunValOrListName :: FunArg -- e.g., toJSONList if True, toJSON if False -> JSONFun -> Arity -> Name -jsonFunValOrListName False = jsonFunValName -jsonFunValOrListName True = jsonFunListName +jsonFunValOrListName Omit = jsonFunOmitName +jsonFunValOrListName Single = jsonFunValName +jsonFunValOrListName Plural = jsonFunListName arityInt :: JSONClass -> Int arityInt = fromEnum . arity diff --git a/src/Data/Aeson/Text.hs b/src/Data/Aeson/Text.hs --- a/src/Data/Aeson/Text.hs +++ b/src/Data/Aeson/Text.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module: Data.Aeson.Text @@ -22,12 +21,12 @@ , encodeToTextBuilder ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude import Data.Aeson.Types (Value(..), ToJSON(..)) import Data.Aeson.Encoding (encodingToLazyByteString) import qualified Data.Aeson.KeyMap as KM -import Data.Scientific (FPFormat(..), Scientific, base10Exponent) +import Data.Scientific (FPFormat(..), base10Exponent) import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as TB import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -- | -- Module: Data.Aeson.Types -- Copyright: (c) 2011-2016 Bryan O'Sullivan @@ -21,6 +20,7 @@ , Series , Array , emptyArray + , isEmptyArray , Pair , Object , emptyObject @@ -51,6 +51,7 @@ -- ** Encoding , ToJSON(..) , KeyValue(..) + , KeyValueOmit(..) -- ** Keys for maps , ToJSONKey(..) @@ -73,14 +74,18 @@ -- ** Liftings to unary and binary type constructors , FromJSON1(..) , parseJSON1 + , omittedField1 , FromJSON2(..) , parseJSON2 + , omittedField2 , ToJSON1(..) , toJSON1 , toEncoding1 + , omitField1 , ToJSON2(..) , toJSON2 , toEncoding2 + , omitField2 -- ** Generic JSON classes , GFromJSON @@ -112,13 +117,19 @@ , (.:?) , (.:!) , (.!=) + , (.:?=) + , (.:!=) , object , parseField , parseFieldMaybe , parseFieldMaybe' + , parseFieldOmit + , parseFieldOmit' , explicitParseField , explicitParseFieldMaybe , explicitParseFieldMaybe' + , explicitParseFieldOmit + , explicitParseFieldOmit' , listEncoding , listValue @@ -133,6 +144,7 @@ , constructorTagModifier , allNullaryToStringTag , omitNothingFields + , allowOmittedFields , sumEncoding , unwrapUnaryRecords , tagSingleConstructors @@ -150,6 +162,9 @@ , keyModifier , defaultJSONKeyOptions + -- * Parsing exceptions + , AesonException (..) + -- * Parsing context , () , JSONPath @@ -158,8 +173,6 @@ , formatRelativePath , formatError ) where - -import Prelude.Compat import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs) import Data.Aeson.Types.Class diff --git a/src/Data/Aeson/Types/Class.hs b/src/Data/Aeson/Types/Class.hs --- a/src/Data/Aeson/Types/Class.hs +++ b/src/Data/Aeson/Types/Class.hs @@ -26,14 +26,18 @@ -- * Liftings to unary and binary type constructors , FromJSON1(..) , parseJSON1 + , omittedField1 , FromJSON2(..) , parseJSON2 + , omittedField2 , ToJSON1(..) , toJSON1 , toEncoding1 + , omitField1 , ToJSON2(..) , toJSON2 , toEncoding2 + , omitField2 -- * Generic JSON classes , GFromJSON(..) , FromArgs(..) @@ -67,6 +71,7 @@ , genericFromJSONKey -- * Object key-value pairs , KeyValue(..) + , KeyValueOmit(..) -- * List functions , listEncoding @@ -89,14 +94,20 @@ , parseField , parseFieldMaybe , parseFieldMaybe' + , parseFieldOmit + , parseFieldOmit' , explicitParseField , explicitParseFieldMaybe , explicitParseFieldMaybe' + , explicitParseFieldOmit + , explicitParseFieldOmit' -- ** Operators , (.:) , (.:?) , (.:!) , (.!=) + , (.:?=) + , (.:!=) ) where diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1,18 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -26,8 +28,10 @@ -- * Liftings to unary and binary type constructors , FromJSON1(..) , parseJSON1 + , omittedField1 , FromJSON2(..) , parseJSON2 + , omittedField2 -- * Generic JSON classes , GFromJSON(..) , FromArgs(..) @@ -62,29 +66,36 @@ , parseField , parseFieldMaybe , parseFieldMaybe' + , parseFieldOmit + , parseFieldOmit' , explicitParseField , explicitParseFieldMaybe , explicitParseFieldMaybe' + , explicitParseFieldOmit + , explicitParseFieldOmit' , parseIndexedJSON -- ** Operators , (.:) , (.:?) , (.:!) , (.!=) - + , (.:?=) + , (.:!=) -- * Internal , parseOptionalFieldWith ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude -import Control.Applicative ((<|>), Const(..), liftA2) -import Control.Monad (zipWithM) +import Control.Monad (zipWithM, guard) +import Data.Aeson.Decoding.ByteString.Lazy +import Data.Aeson.Decoding.Conversion (unResult, toResultValue, lbsSpace) import Data.Aeson.Internal.Functions (mapKey, mapKeyO) -import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF) +import Data.Aeson.Internal.Scientific import Data.Aeson.Types.Generic import Data.Aeson.Types.Internal import Data.Bits (unsafeShiftR) +import Data.Complex (Complex(..)) import Data.Fixed (Fixed, HasResolution (resolution), Nano) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) @@ -92,16 +103,15 @@ import Data.Functor.Sum (Sum(..)) import Data.Functor.These (These1 (..)) import Data.Hashable (Hashable(..)) -import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy(..)) +import Data.Ord (Down (..)) import Data.Ratio ((%), Ratio) -import Data.Scientific (Scientific, base10Exponent) +import Data.Scientific (base10Exponent) import Data.Tagged (Tagged(..)) -import Data.Text (Text, pack, unpack) +import Data.Text (pack, unpack) import Data.These (These (..)) -import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, ZonedTime) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) @@ -111,28 +121,18 @@ import Data.Traversable as Tr (sequence) import Data.Tuple.Solo (Solo (..)) import Data.Type.Coercion (Coercion (..)) -import Data.Vector (Vector) import Data.Version (Version, parseVersion) -import Data.Void (Void) -import Data.Word (Word16, Word32, Word64, Word8) import Foreign.Storable (Storable) import Foreign.C.Types (CTime (..)) import GHC.Generics -#if !MIN_VERSION_base(4,17,0) -import GHC.Generics.Generically (Generically (..), Generically1 (..)) -#endif -import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson.Parser.Time as Time import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM -import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific) import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList -#if MIN_VERSION_dlist(1,0,0) import qualified Data.DList.DNonEmpty as DNE -#endif import qualified Data.Fix as F import qualified Data.HashMap.Strict as H import qualified Data.HashSet as HashSet @@ -156,6 +156,7 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU +import qualified Network.URI as URI import qualified GHC.Exts as Exts import qualified Data.Primitive.Array as PM @@ -163,8 +164,6 @@ import qualified Data.Primitive.Types as PM import qualified Data.Primitive.PrimArray as PM -import Data.Coerce (Coercible, coerce) - #if __GLASGOW_HASKELL__ < 804 import qualified Data.Type.Coercion #endif @@ -214,21 +213,26 @@ prependContext name . withScientific' parseBoundedIntegralFromScientific parseScientificText :: Text -> Parser Scientific -parseScientificText - = either fail pure - . A.parseOnly (A.scientific <* A.endOfInput) - . T.encodeUtf8 +parseScientificText = scanScientific + (\sci rest -> if T.null rest then return sci else fail $ "Expecting end-of-input, got " ++ show (T.take 10 rest)) + fail -parseIntegralText :: Integral a => String -> Text -> Parser a -parseIntegralText name t = +parseBoundedScientificTextTo :: (Scientific -> Parser a) -> String -> Text -> Parser a +parseBoundedScientificTextTo toResultType name t = prependContext name $ parseScientificText t >>= rejectLargeExponent - >>= parseIntegralFromScientific + >>= toResultType where rejectLargeExponent :: Scientific -> Parser Scientific rejectLargeExponent s = withBoundedScientific' pure (Number s) +parseBoundedScientificText :: String -> Text -> Parser Scientific +parseBoundedScientificText = parseBoundedScientificTextTo pure + +parseIntegralText :: Integral a => String -> Text -> Parser a +parseIntegralText = parseBoundedScientificTextTo parseIntegralFromScientific + parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a parseBoundedIntegralText name t = prependContext name $ @@ -253,11 +257,11 @@ gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a) -- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the --- two function arguments that decode occurrences of the type parameter (for +-- three function arguments that decode occurrences of the type parameter (for -- 'FromJSON1'). data FromArgs arity a where NoFromArgs :: FromArgs Zero a - From1Args :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a + From1Args :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a -- | A configurable generic JSON decoder. This function applied to -- 'defaultOptions' is used as the default for 'parseJSON' when the @@ -270,9 +274,9 @@ -- 'defaultOptions' is used as the default for 'liftParseJSON' when the -- type is an instance of 'Generic1'. genericLiftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f)) - => Options -> (Value -> Parser a) -> (Value -> Parser [a]) + => Options -> Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) -genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl) +genericLiftParseJSON opts o pj pjl = fmap to1 . gParseJSON opts (From1Args o pj pjl) ------------------------------------------------------------------------------- -- Class @@ -395,6 +399,14 @@ . V.toList $ a + -- | Default value for optional fields. + -- Used by @('.:?=')@ operator, and Generics and TH deriving + -- with @'allowOmittedFields' = True@ (default). + -- + -- @since 2.2.0.0 + omittedField :: Maybe a + omittedField = Nothing + -- | @since 2.1.0.0 instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Generically a) where parseJSON = coerce (genericParseJSON defaultOptions :: Value -> Parser a) @@ -607,25 +619,32 @@ -- 'liftParseJSON' = 'genericLiftParseJSON' customOptions -- @ class FromJSON1 f where - liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) + liftParseJSON :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) default liftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f)) - => (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) + => Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) liftParseJSON = genericLiftParseJSON defaultOptions - liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a] - liftParseJSONList f g v = listParser (liftParseJSON f g) v + liftParseJSONList :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a] + liftParseJSONList o f g v = listParser (liftParseJSON o f g) v + liftOmittedField :: Maybe a -> Maybe (f a) + liftOmittedField _ = Nothing + -- | @since 2.1.0.0 instance (Generic1 f, GFromJSON One (Rep1 f)) => FromJSON1 (Generically1 f) where - liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (Generically1 f a) - liftParseJSON = coerce (genericLiftParseJSON defaultOptions :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)) + liftParseJSON :: forall a. Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (Generically1 f a) + liftParseJSON = coerce (genericLiftParseJSON defaultOptions :: Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)) -- | Lift the standard 'parseJSON' function through the type constructor. parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a) -parseJSON1 = liftParseJSON parseJSON parseJSONList +parseJSON1 = liftParseJSON omittedField parseJSON parseJSONList {-# INLINE parseJSON1 #-} +-- | @since 2.2.0.0 +omittedField1 :: (FromJSON1 f, FromJSON a) => Maybe (f a) +omittedField1 = liftOmittedField omittedField + -- | Lifting of the 'FromJSON' class to binary type constructors. -- -- Instead of manually writing your 'FromJSON2' instance, "Data.Aeson.TH" @@ -635,25 +654,36 @@ -- unlike 'parseJSON' and 'liftParseJSON'. class FromJSON2 f where liftParseJSON2 - :: (Value -> Parser a) + :: Maybe a + -> (Value -> Parser a) -> (Value -> Parser [a]) + -> Maybe b -> (Value -> Parser b) -> (Value -> Parser [b]) -> Value -> Parser (f a b) liftParseJSONList2 - :: (Value -> Parser a) + :: Maybe a + -> (Value -> Parser a) -> (Value -> Parser [a]) + -> Maybe b -> (Value -> Parser b) -> (Value -> Parser [b]) -> Value -> Parser [f a b] - liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals -> - fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals) + liftParseJSONList2 oa fa ga ob fb gb = withArray "[]" $ \vals -> + fmap V.toList (V.mapM (liftParseJSON2 oa fa ga ob fb gb) vals) + liftOmittedField2 :: Maybe a -> Maybe b -> Maybe (f a b) + liftOmittedField2 _ _ = Nothing + -- | Lift the standard 'parseJSON' function through the type constructor. parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b) -parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList +parseJSON2 = liftParseJSON2 omittedField parseJSON parseJSONList omittedField parseJSON parseJSONList {-# INLINE parseJSON2 #-} +-- | @since 2.2.0.0 +omittedField2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Maybe (f a b) +omittedField2 = liftOmittedField2 omittedField omittedField + ------------------------------------------------------------------------------- -- List functions ------------------------------------------------------------------------------- @@ -669,7 +699,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 [] where - liftParseJSON _ p' = p' + liftParseJSON _ _ p' = p' instance (FromJSON a) => FromJSON [a] where parseJSON = parseJSON1 @@ -773,11 +803,13 @@ withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a withBoundedScientific_ whenFail f (Number scientific) = if exp10 > 1024 - then whenFail (fail msg) + then whenFail (fail (msg "greater than 1024")) + else if exp10 < -1024 + then whenFail (fail (msg "less than -1024")) else f scientific where exp10 = base10Exponent scientific - msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024" + msg req = "found a number with exponent " ++ show exp10 ++ ", but it must not be " ++ req withBoundedScientific_ whenFail _ v = whenFail (typeMismatch "Number" v) @@ -797,8 +829,14 @@ withEmbeddedJSON _ innerParser (String txt) = either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt) where - eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON - eitherFormatError = either (Left . uncurry formatError) Right + -- TODO: decode from strict text + eitherDecode :: (FromJSON a) => L.ByteString -> Either String a + eitherDecode bs = unResult (toResultValue (lbsToTokens bs)) Left $ \v bs' -> case ifromJSON v of + ISuccess x + | lbsSpace bs' -> Right x + | otherwise -> Left "Trailing garbage" + IError path msg -> Left $ formatError path msg + withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v) -- | Convert a value from JSON, failing if the types do not match. @@ -838,6 +876,25 @@ (.:!) :: (FromJSON a) => Object -> Key -> Parser (Maybe a) (.:!) = explicitParseFieldMaybe' parseJSON +-- | Retrieve the value associated with the given key of an 'Object'. +-- If the key is not present or the field is @null@ and the 'omittedField' is @'Just' x@ for some @x@, +-- the result will be that @x@. +-- +-- @since 2.2.0.0 +(.:?=) :: (FromJSON a) => Object -> Key -> Parser a +(.:?=) = explicitParseFieldOmit omittedField parseJSON + +-- | Retrieve the value associated with the given key of an 'Object'. +-- If the key is not present and the 'omittedField' is @'Just' x@ for some @x@, +-- the result will be that @x@. +-- +-- This differs from '.:?=' by attempting to parse 'Null' the same as any +-- other JSON value, instead of using 'omittedField' when it's 'Just'. +-- +-- @since 2.2.0.0 +(.:!=) :: (FromJSON a) => Object -> Key -> Parser a +(.:!=) = explicitParseFieldOmit' omittedField parseJSON + -- | Function variant of '.:'. parseField :: (FromJSON a) => Object -> Key -> Parser a parseField = (.:) @@ -850,6 +907,18 @@ parseFieldMaybe' :: (FromJSON a) => Object -> Key -> Parser (Maybe a) parseFieldMaybe' = (.:!) +-- | Function variant of '.:?='. +-- +-- @since 2.2.0.0 +parseFieldOmit :: (FromJSON a) => Object -> Key -> Parser a +parseFieldOmit = (.:?=) + +-- | Function variant of '.:!='. +-- +-- @since 2.2.0.0 +parseFieldOmit' :: (FromJSON a) => Object -> Key -> Parser a +parseFieldOmit' = (.:!=) + -- | Variant of '.:' with explicit parser function. -- -- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@ @@ -862,7 +931,7 @@ explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a) explicitParseFieldMaybe p obj key = case KM.lookup key obj of Nothing -> pure Nothing - Just v -> liftParseJSON p (listParser p) v Key key -- listParser isn't used by maybe instance. + Just v -> liftParseJSON Nothing p (listParser p) v Key key -- listParser isn't used by maybe instance. -- | Variant of '.:!' with explicit parser function. explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a) @@ -870,6 +939,20 @@ Nothing -> pure Nothing Just v -> Just <$> p v Key key +-- | Variant of '.:?=' with explicit arguments. +-- +-- @since 2.2.0.0 +explicitParseFieldOmit :: Maybe a -> (Value -> Parser a) -> Object -> Key -> Parser a +explicitParseFieldOmit Nothing p obj key = explicitParseField p obj key +explicitParseFieldOmit (Just def) p obj key = explicitParseFieldMaybe p obj key .!= def + +-- | Variant of '.:!=' with explicit arguments. +-- +-- @since 2.2.0.0 +explicitParseFieldOmit' :: Maybe a -> (Value -> Parser a) -> Object -> Key -> Parser a +explicitParseFieldOmit' Nothing p obj key = explicitParseField p obj key +explicitParseFieldOmit' (Just def) p obj key = explicitParseFieldMaybe' p obj key .!= def + -- | Helper for use in combination with '.:?' to provide default -- values for optional JSON object fields. -- @@ -942,22 +1025,25 @@ instance GFromJSON One Par1 where -- Direct occurrences of the last type parameter are decoded with the -- function passed in as an argument: - gParseJSON _opts (From1Args pj _) = fmap Par1 . pj + gParseJSON _opts (From1Args _ pj _) = fmap Par1 . pj {-# INLINE gParseJSON #-} instance (FromJSON1 f) => GFromJSON One (Rec1 f) where -- Recursive occurrences of the last type parameter are decoded using their -- FromJSON1 instance: - gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl + gParseJSON _opts (From1Args o pj pjl) = fmap Rec1 . liftParseJSON o pj pjl {-# INLINE gParseJSON #-} instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is decoded by using the outermost type's FromJSON1 -- instance to generically decode the innermost type: + -- + -- Note: the ommitedField is not passed here. + -- This might be related for :.: associated the wrong way in Generics Rep. gParseJSON opts fargs = - let gpj = gParseJSON opts fargs in - fmap Comp1 . liftParseJSON gpj (listParser gpj) + let gpj = gParseJSON opts fargs + in fmap Comp1 . liftParseJSON Nothing gpj (listParser gpj) {-# INLINE gParseJSON #-} -------------------------------------------------------------------------------- @@ -1346,35 +1432,57 @@ <*> recordParseJSON' p obj {-# INLINE recordParseJSON' #-} -instance {-# OVERLAPPABLE #-} (Selector s, GFromJSON arity a) => - RecordFromJSON' arity (S1 s a) where - recordParseJSON' (cname :* tname :* opts :* fargs) obj = do - fv <- contextCons cname tname (obj .: label) - M1 <$> gParseJSON opts fargs fv Key label - where - label = Key.fromString $ fieldLabelModifier opts sname - sname = selName (undefined :: M1 _i s _f _p) +instance {-# OVERLAPPABLE #-} + RecordFromJSON' arity f => RecordFromJSON' arity (M1 i s f) where + recordParseJSON' args obj = M1 <$> recordParseJSON' args obj {-# INLINE recordParseJSON' #-} -instance {-# INCOHERENT #-} (Selector s, FromJSON a) => - RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where - recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? label - where - label = Key.fromString $ fieldLabelModifier opts sname - sname = selName (undefined :: M1 _i s _f _p) +instance (Selector s, FromJSON a, Generic a, K1 i a ~ Rep a) => + RecordFromJSON' arity (S1 s (K1 i a)) where + recordParseJSON' args@(_ :* _ :* opts :* _) obj = + recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap K1 omittedField) gParseJSON args obj {-# INLINE recordParseJSON' #-} -#if !MIN_VERSION_base(4,16,0) --- Parse an Option like a Maybe. -instance {-# INCOHERENT #-} (Selector s, FromJSON a) => - RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where - recordParseJSON' p obj = wrap <$> recordParseJSON' p obj - where - wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p - wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a)) +instance {-# OVERLAPPING #-} + (Selector s, FromJSON a) => + RecordFromJSON' arity (S1 s (Rec0 a)) where + recordParseJSON' args@(_ :* _ :* opts :* _) obj = + recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap K1 omittedField) gParseJSON args obj {-# INLINE recordParseJSON' #-} -#endif +instance {-# OVERLAPPING #-} + (Selector s, GFromJSON One (Rec1 f), FromJSON1 f) => + RecordFromJSON' One (S1 s (Rec1 f)) where + recordParseJSON' args@(_ :* _ :* opts :* From1Args o _ _) obj = + recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap Rec1 (liftOmittedField o)) gParseJSON args obj + {-# INLINE recordParseJSON' #-} + +instance {-# OVERLAPPING #-} + (Selector s, GFromJSON One Par1) => + RecordFromJSON' One (S1 s Par1) where + recordParseJSON' args@(_ :* _ :* opts :* From1Args o _ _) obj = + recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap Par1 o) gParseJSON args obj + {-# INLINE recordParseJSON' #-} + + +recordParseJSONImpl :: forall s arity a f i + . (Selector s) + => Maybe (f a) + -> (Options -> FromArgs arity a -> Value -> Parser (f a)) + -> (ConName :* TypeName :* Options :* FromArgs arity a) + -> Object -> Parser (M1 i s f a) +recordParseJSONImpl mdef parseVal (cname :* tname :* opts :* fargs) obj = + handleMissingKey (M1 <$> mdef) $ do + fv <- contextCons cname tname (obj .: label) + M1 <$> parseVal opts fargs fv Key label + where + handleMissingKey Nothing p = p + handleMissingKey (Just def) p = if label `KM.member` obj then p else pure def + + label = Key.fromString $ fieldLabelModifier opts sname + sname = selName (undefined :: M1 _i s _f _p) +{-# INLINE recordParseJSONImpl #-} + -------------------------------------------------------------------------------- productParseJSON0 @@ -1499,28 +1607,33 @@ instance FromJSON2 Const where - liftParseJSON2 p _ _ _ = fmap Const . p + liftParseJSON2 _ p _ _ _ _ = coerce p + liftOmittedField2 o _ = coerce o instance FromJSON a => FromJSON1 (Const a) where - liftParseJSON _ _ = fmap Const . parseJSON + liftParseJSON _ _ _ = coerce (parseJSON @a) + liftOmittedField _ = coerce (omittedField @a) instance FromJSON a => FromJSON (Const a b) where - parseJSON = fmap Const . parseJSON + parseJSON = coerce (parseJSON @a) + omittedField = coerce (omittedField @a) instance (FromJSON a, FromJSONKey a) => FromJSONKey (Const a b) where - fromJSONKey = fmap Const fromJSONKey + fromJSONKey = coerce (fromJSONKey @a) instance FromJSON1 Maybe where - liftParseJSON _ _ Null = pure Nothing - liftParseJSON p _ a = Just <$> p a + liftParseJSON _ _ _ Null = pure Nothing + liftParseJSON _ p _ a = Just <$> p a + liftOmittedField _ = Just Nothing + instance (FromJSON a) => FromJSON (Maybe a) where parseJSON = parseJSON1 - + omittedField = omittedField1 instance FromJSON2 Either where - liftParseJSON2 pA _ pB _ (Object (KM.toList -> [(key, value)])) + liftParseJSON2 _ pA _ _ pB _ (Object (KM.toList -> [(key, value)])) | key == left = Left <$> pA value Key left | key == right = Right <$> pB value Key right where @@ -1528,13 +1641,13 @@ left = "Left" right = "Right" - liftParseJSON2 _ _ _ _ _ = fail $ + liftParseJSON2 _ _ _ _ _ _ _ = fail $ "expected an object with a single property " ++ "where the property key should be either " ++ "\"Left\" or \"Right\"" instance (FromJSON a) => FromJSON1 (Either a) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where parseJSON = parseJSON2 @@ -1567,6 +1680,7 @@ instance FromJSON () where parseJSON _ = pure () + omittedField = Just () instance FromJSON Char where parseJSON = withText "Char" parseChar @@ -1601,14 +1715,7 @@ _ -> Scientific.toRealFloat <$> parseScientificText t instance (FromJSON a, Integral a) => FromJSON (Ratio a) where - parseJSON (Number x) - | exp10 <= 1024 - , exp10 >= -1024 = return $! realToFrac x - | otherwise = prependContext "Ratio" $ fail msg - where - exp10 = base10Exponent x - msg = "found a number with exponent " ++ show exp10 - ++ ", but it must not be greater than 1024 or less than -1024" + parseJSON n@(Number _) = withBoundedScientific "Ratio" (($!) pure . realToFrac) n parseJSON o = objParser o where objParser = withObject "Rational" $ \obj -> do @@ -1618,6 +1725,17 @@ then fail "Ratio denominator was 0" else pure $ numerator % denominator +-- | A complex number @x+iy@ is encoded as an array @[x, y]@. +-- +-- @since 2.3.1.0 +instance FromJSON a => FromJSON (Complex a) where + parseJSON = withArray "Complex" $ \c -> + let n = V.length c + in if n == 2 + then (:+) <$> parseJSONElemAtIndex parseJSON 0 c + <*> parseJSONElemAtIndex parseJSON 1 c + else fail $ "cannot unpack array of length " ++ show n ++ "into a Complex" + -- | This instance includes a bounds check to prevent maliciously -- large inputs to fill up the memory of the target system. You can -- newtype 'Scientific' and provide your own instance using @@ -1625,6 +1743,12 @@ instance HasResolution a => FromJSON (Fixed a) where parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac) +-- | +-- @since 2.3.1.0 +instance HasResolution a => FromJSONKey (Fixed a) where + fromJSONKey = FromJSONKeyTextParser $ \t -> + realToFrac <$> parseBoundedScientificText "Fixed" t + instance FromJSON Int where parseJSON = parseBoundedIntegral "Int" @@ -1755,7 +1879,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 NonEmpty where - liftParseJSON p _ = withArray "NonEmpty" $ + liftParseJSON _ p _ = withArray "NonEmpty" $ (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList where ne [] = fail "parsing NonEmpty failed, unexpected empty list" @@ -1776,17 +1900,16 @@ ------------------------------------------------------------------------------- instance FromJSON1 DList.DList where - liftParseJSON p _ = withArray "DList" $ + liftParseJSON _ p _ = withArray "DList" $ fmap DList.fromList . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList instance (FromJSON a) => FromJSON (DList.DList a) where parseJSON = parseJSON1 -#if MIN_VERSION_dlist(1,0,0) -- | @since 1.5.3.0 instance FromJSON1 DNE.DNonEmpty where - liftParseJSON p _ = withArray "DNonEmpty" $ + liftParseJSON _ p _ = withArray "DNonEmpty" $ (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList where ne [] = fail "parsing DNonEmpty failed, unexpected empty list" @@ -1795,7 +1918,6 @@ -- | @since 1.5.3.0 instance (FromJSON a) => FromJSON (DNE.DNonEmpty a) where parseJSON = parseJSON1 -#endif ------------------------------------------------------------------------------- -- OneTuple @@ -1803,13 +1925,13 @@ -- | @since 2.0.2.0 instance FromJSON1 Solo where - liftParseJSON p _ a = Solo <$> p a - liftParseJSONList _ p a = fmap Solo <$> p a + liftParseJSON _ p _ a = Solo <$> p a + liftParseJSONList _ _ p a = fmap Solo <$> p a -- | @since 2.0.2.0 instance (FromJSON a) => FromJSON (Solo a) where parseJSON = parseJSON1 - parseJSONList = liftParseJSONList parseJSON parseJSONList + parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList -- | @since 2.0.2.0 instance (FromJSONKey a) => FromJSONKey (Solo a) where @@ -1821,14 +1943,11 @@ ------------------------------------------------------------------------------- instance FromJSON1 Identity where - liftParseJSON p _ a = Identity <$> p a - - liftParseJSONList _ p a = fmap Identity <$> p a - -instance (FromJSON a) => FromJSON (Identity a) where - parseJSON = parseJSON1 + liftParseJSON _ p _ a = coerce (p a) + liftParseJSONList _ _ p a = coerce (p a) + liftOmittedField = coerce - parseJSONList = liftParseJSONList parseJSON parseJSONList +deriving via (a :: Type) instance FromJSON a => FromJSON (Identity a) instance (FromJSONKey a) => FromJSONKey (Identity a) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a) @@ -1836,44 +1955,45 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where - liftParseJSON p pl a = Compose <$> liftParseJSON g gl a + liftParseJSON o p pl a = coerce (liftParseJSON @f (liftOmittedField o) g gl a) where - g = liftParseJSON p pl - gl = liftParseJSONList p pl + g = liftParseJSON @g o p pl + gl = liftParseJSONList @g o p pl - liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a + liftParseJSONList o p pl a = coerce (liftParseJSONList @f (liftOmittedField o) g gl a) where - g = liftParseJSON p pl - gl = liftParseJSONList p pl + g = liftParseJSON @g o p pl + gl = liftParseJSONList @g o p pl instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where parseJSON = parseJSON1 - parseJSONList = liftParseJSONList parseJSON parseJSONList - + parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Product f g) where - liftParseJSON p pl a = uncurry Pair <$> liftParseJSON2 px pxl py pyl a + liftParseJSON o p pl a = uncurry Pair <$> liftParseJSON2 ox px pxl oy py pyl a where - px = liftParseJSON p pl - pxl = liftParseJSONList p pl - py = liftParseJSON p pl - pyl = liftParseJSONList p pl + ox = liftOmittedField o + px = liftParseJSON o p pl + pxl = liftParseJSONList o p pl + oy = liftOmittedField o + py = liftParseJSON o p pl + pyl = liftParseJSONList o p pl instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where parseJSON = parseJSON1 instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where - liftParseJSON p pl (Object (KM.toList -> [(key, value)])) - | key == inl = InL <$> liftParseJSON p pl value Key inl - | key == inr = InR <$> liftParseJSON p pl value Key inr + liftParseJSON o p pl (Object (KM.toList -> [(key, value)])) + | key == inl = InL <$> liftParseJSON o p pl value Key inl + | key == inr = InR <$> liftParseJSON o p pl value Key inr where inl, inr :: Key inl = "InL" inr = "InR" - liftParseJSON _ _ _ = fail $ + liftParseJSON _ _ _ _ = fail $ "parsing Sum failed, expected an object with a single property " ++ "where the property key should be either " ++ "\"InL\" or \"InR\"" @@ -1886,7 +2006,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 Seq.Seq where - liftParseJSON p _ = withArray "Seq" $ + liftParseJSON _ p _ = withArray "Seq" $ fmap Seq.fromList . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList @@ -1903,18 +2023,19 @@ instance FromJSON1 IntMap.IntMap where - liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl' + liftParseJSON o p pl = fmap IntMap.fromList . liftParseJSON o' p' pl' where - p' = liftParseJSON2 parseJSON parseJSONList p pl - pl' = liftParseJSONList2 parseJSON parseJSONList p pl + o' = liftOmittedField o + p' = liftParseJSON o p pl + pl' = liftParseJSONList o p pl instance FromJSON a => FromJSON (IntMap.IntMap a) where parseJSON = fmap IntMap.fromList . parseJSON instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where - liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (M.Map k a) - liftParseJSON p _ = case fromJSONKey of + liftParseJSON :: forall a. Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (M.Map k a) + liftParseJSON _ p _ = case fromJSONKey of FromJSONKeyCoerce -> withObject "Map ~Text" $ case Key.coercionToText of Nothing -> text coerce Just Coercion -> case KM.coercionToMap of @@ -1945,12 +2066,13 @@ instance FromJSON1 Tree.Tree where - liftParseJSON p pl = go + liftParseJSON o p pl = go where - go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v + go v = uncurry Tree.Node <$> liftParseJSON2 o p pl o' p' pl' v - p' = liftParseJSON go (listParser go) - pl'= liftParseJSONList go (listParser go) + o' = Nothing + p' = liftParseJSON Nothing go (listParser go) + pl'= liftParseJSONList Nothing go (listParser go) instance (FromJSON v) => FromJSON (Tree.Tree v) where parseJSON = parseJSON1 @@ -1972,7 +2094,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 Vector where - liftParseJSON p _ = withArray "Vector" $ + liftParseJSON _ p _ = withArray "Vector" $ V.mapM (uncurry $ parseIndexedJSON p) . V.indexed instance (FromJSON a) => FromJSON (Vector a) where @@ -2000,8 +2122,8 @@ instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where - liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (H.HashMap k a) - liftParseJSON p _ = case fromJSONKey of + liftParseJSON :: forall a. Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (H.HashMap k a) + liftParseJSON _ p _ = case fromJSONKey of FromJSONKeyCoerce -> withObject "HashMap ~Text" $ case Key.coercionToText of Nothing -> text coerce Just Coercion -> case KM.coercionToHashMap of @@ -2051,7 +2173,7 @@ -- | @since 2.0.1.0 instance FromJSON1 KM.KeyMap where - liftParseJSON p _ = withObject "KeyMap" $ \obj -> + liftParseJSON _ p _ = withObject "KeyMap" $ \obj -> traverse p obj -- | @since 2.0.1.0 @@ -2089,31 +2211,31 @@ ------------------------------------------------------------------------------- instance FromJSON Day where - parseJSON = withText "Day" (Time.run Time.day) + parseJSON = withText "Day" (Time.run Time.parseDay) instance FromJSONKey Day where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.day) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseDay) instance FromJSON TimeOfDay where - parseJSON = withText "TimeOfDay" (Time.run Time.timeOfDay) + parseJSON = withText "TimeOfDay" (Time.run Time.parseTimeOfDay) instance FromJSONKey TimeOfDay where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.timeOfDay) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseTimeOfDay) instance FromJSON LocalTime where - parseJSON = withText "LocalTime" (Time.run Time.localTime) + parseJSON = withText "LocalTime" (Time.run Time.parseLocalTime) instance FromJSONKey LocalTime where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseLocalTime) -- | Supported string formats: -- --- @YYYY-MM-DD HH:MM Z@ --- @YYYY-MM-DD HH:MM:SS Z@ --- @YYYY-MM-DD HH:MM:SS.SSS Z@ +-- @YYYY-MM-DD HH:MMZ@ +-- @YYYY-MM-DD HH:MM:SSZ@ +-- @YYYY-MM-DD HH:MM:SS.SSSZ@ -- -- 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 @@ -2121,17 +2243,17 @@ -- 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) + parseJSON = withText "ZonedTime" (Time.run Time.parseZonedTime) instance FromJSONKey ZonedTime where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.zonedTime) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseZonedTime) instance FromJSON UTCTime where - parseJSON = withText "UTCTime" (Time.run Time.utcTime) + parseJSON = withText "UTCTime" (Time.run Time.parseUTCTime) instance FromJSONKey UTCTime where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseUTCTime) -- | This instance includes a bounds check to prevent maliciously @@ -2184,116 +2306,80 @@ fromJSONKey = FromJSONKeyTextParser parseDayOfWeek instance FromJSON QuarterOfYear where - parseJSON = withText "DaysOfWeek" parseQuarterOfYear - -parseQuarterOfYear :: T.Text -> Parser QuarterOfYear -parseQuarterOfYear t = case T.toLower t of - "q1" -> return Q1 - "q2" -> return Q2 - "q3" -> return Q3 - "q4" -> return Q4 - _ -> fail "Invalid quarter of year" + parseJSON = withText "QuarterOfYear" (Time.run Time.parseQuarterOfYear) instance FromJSONKey QuarterOfYear where - fromJSONKey = FromJSONKeyTextParser parseQuarterOfYear + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseQuarterOfYear) instance FromJSON Quarter where - parseJSON = withText "Quarter" (Time.run Time.quarter) + parseJSON = withText "Quarter" (Time.run Time.parseQuarter) instance FromJSONKey Quarter where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.quarter) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseQuarter) instance FromJSON Month where - parseJSON = withText "Month" (Time.run Time.month) + parseJSON = withText "Month" (Time.run Time.parseMonth) instance FromJSONKey Month where - fromJSONKey = FromJSONKeyTextParser (Time.run Time.month) + fromJSONKey = FromJSONKeyTextParser (Time.run Time.parseMonth) ------------------------------------------------------------------------------- --- base Monoid/Semigroup +-- base Down ------------------------------------------------------------------------------- -instance FromJSON1 Monoid.Dual where - liftParseJSON p _ = fmap Monoid.Dual . p - -instance FromJSON a => FromJSON (Monoid.Dual a) where - parseJSON = parseJSON1 - - -instance FromJSON1 Monoid.First where - liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p' - -instance FromJSON a => FromJSON (Monoid.First a) where - parseJSON = parseJSON1 - - -instance FromJSON1 Monoid.Last where - liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p' - -instance FromJSON a => FromJSON (Monoid.Last a) where - parseJSON = parseJSON1 - - -instance FromJSON1 Semigroup.Min where - liftParseJSON p _ a = Semigroup.Min <$> p a - - liftParseJSONList _ p a = fmap Semigroup.Min <$> p a - -instance (FromJSON a) => FromJSON (Semigroup.Min a) where - parseJSON = parseJSON1 - - parseJSONList = liftParseJSONList parseJSON parseJSONList - - -instance FromJSON1 Semigroup.Max where - liftParseJSON p _ a = Semigroup.Max <$> p a - - liftParseJSONList _ p a = fmap Semigroup.Max <$> p a - -instance (FromJSON a) => FromJSON (Semigroup.Max a) where - parseJSON = parseJSON1 - - parseJSONList = liftParseJSONList parseJSON parseJSONList - +-- | @since 2.2.0.0 +deriving via Identity instance FromJSON1 Down -instance FromJSON1 Semigroup.First where - liftParseJSON p _ a = Semigroup.First <$> p a +-- | @since 2.2.0.0 +deriving via (a :: Type) instance FromJSON a => FromJSON (Down a) - liftParseJSONList _ p a = fmap Semigroup.First <$> p a +------------------------------------------------------------------------------- +-- base Monoid/Semigroup +------------------------------------------------------------------------------- -instance (FromJSON a) => FromJSON (Semigroup.First a) where - parseJSON = parseJSON1 +deriving via Identity instance FromJSON1 Monoid.Dual +deriving via (a :: Type) instance FromJSON a => FromJSON (Monoid.Dual a) - parseJSONList = liftParseJSONList parseJSON parseJSONList +deriving via Maybe instance FromJSON1 Monoid.First +deriving via Maybe a instance FromJSON a => FromJSON (Monoid.First a) +deriving via Maybe instance FromJSON1 Monoid.Last +deriving via Maybe a instance FromJSON a => FromJSON (Monoid.Last a) -instance FromJSON1 Semigroup.Last where - liftParseJSON p _ a = Semigroup.Last <$> p a +deriving via Identity instance FromJSON1 Semigroup.Min +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Min a) - liftParseJSONList _ p a = fmap Semigroup.Last <$> p a +deriving via Identity instance FromJSON1 Semigroup.Max +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Max a) -instance (FromJSON a) => FromJSON (Semigroup.Last a) where - parseJSON = parseJSON1 +deriving via Identity instance FromJSON1 Semigroup.First +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.First a) - parseJSONList = liftParseJSONList parseJSON parseJSONList +deriving via Identity instance FromJSON1 Semigroup.Last +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Last a) +deriving via Identity instance FromJSON1 Semigroup.WrappedMonoid +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.WrappedMonoid a) -instance FromJSON1 Semigroup.WrappedMonoid where - liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a +-- | @since 2.2.3.0 +deriving via Identity instance FromJSON1 Semigroup.Sum +-- | @since 2.2.3.0 +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Sum a) - liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a +-- | @since 2.2.3.0 +deriving via Identity instance FromJSON1 Semigroup.Product +-- | @since 2.2.3.0 +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Product a) -instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where - parseJSON = parseJSON1 +-- | @since 2.2.3.0 +deriving via Bool instance FromJSON Semigroup.All - parseJSONList = liftParseJSONList parseJSON parseJSONList +-- | @since 2.2.3.0 +deriving via Bool instance FromJSON Semigroup.Any #if !MIN_VERSION_base(4,16,0) -instance FromJSON1 Semigroup.Option where - liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p' - -instance FromJSON a => FromJSON (Semigroup.Option a) where - parseJSON = parseJSON1 +deriving via Maybe instance FromJSON1 Semigroup.Option +deriving via Maybe a instance FromJSON a => FromJSON (Semigroup.Option a) #endif ------------------------------------------------------------------------------- @@ -2302,7 +2388,7 @@ -- | @since 1.5.3.0 instance FromJSON1 f => FromJSON (F.Fix f) where - parseJSON = go where go = fmap F.Fix . liftParseJSON go parseJSONList + parseJSON = go where go = coerce (liftParseJSON @f Nothing go parseJSONList) -- | @since 1.5.3.0 instance (FromJSON1 f, Functor f) => FromJSON (F.Mu f) where @@ -2313,6 +2399,23 @@ parseJSON = fmap (F.unfoldNu F.unFix) . parseJSON ------------------------------------------------------------------------------- +-- network-uri +------------------------------------------------------------------------------- + +-- | @since 2.2.0.0 +instance FromJSON URI.URI where + parseJSON = withText "URI" parseURI + +-- | @since 2.2.0.0 +instance FromJSONKey URI.URI where + fromJSONKey = FromJSONKeyTextParser parseURI + +parseURI :: Text -> Parser URI.URI +parseURI t = case URI.parseURI (T.unpack t) of + Nothing -> fail "Invalid URI" + Just x -> return x + +------------------------------------------------------------------------------- -- strict ------------------------------------------------------------------------------- @@ -2322,11 +2425,11 @@ -- | @since 1.5.3.0 instance FromJSON2 S.These where - liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs + liftParseJSON2 oa pa pas ob pb pbs = fmap S.toStrict . liftParseJSON2 oa pa pas ob pb pbs -- | @since 1.5.3.0 instance FromJSON a => FromJSON1 (S.These a) where - liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas + liftParseJSON oa pa pas = fmap S.toStrict . liftParseJSON oa pa pas -- | @since 1.5.3.0 instance (FromJSON a, FromJSON b) => FromJSON (S.Pair a b) where @@ -2334,11 +2437,11 @@ -- | @since 1.5.3.0 instance FromJSON2 S.Pair where - liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs + liftParseJSON2 oa pa pas ob pb pbs = fmap S.toStrict . liftParseJSON2 oa pa pas ob pb pbs -- | @since 1.5.3.0 instance FromJSON a => FromJSON1 (S.Pair a) where - liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas + liftParseJSON oa pa pas = fmap S.toStrict . liftParseJSON oa pa pas -- | @since 1.5.3.0 instance (FromJSON a, FromJSON b) => FromJSON (S.Either a b) where @@ -2346,38 +2449,45 @@ -- | @since 1.5.3.0 instance FromJSON2 S.Either where - liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs + liftParseJSON2 oa pa pas ob pb pbs = fmap S.toStrict . liftParseJSON2 oa pa pas ob pb pbs -- | @since 1.5.3.0 instance FromJSON a => FromJSON1 (S.Either a) where - liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas + liftParseJSON oa pa pas = fmap S.toStrict . liftParseJSON oa pa pas -- | @since 1.5.3.0 instance FromJSON a => FromJSON (S.Maybe a) where parseJSON = fmap S.toStrict . parseJSON + omittedField = fmap S.toStrict omittedField -- | @since 1.5.3.0 instance FromJSON1 S.Maybe where - liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas + liftParseJSON oa pa pas = fmap S.toStrict . liftParseJSON oa pa pas + liftOmittedField = fmap S.toStrict . liftOmittedField ------------------------------------------------------------------------------- -- tagged ------------------------------------------------------------------------------- instance FromJSON1 Proxy where - liftParseJSON _ _ _ = pure Proxy + liftParseJSON _ _ _ _ = pure Proxy + liftOmittedField _ = Just Proxy instance FromJSON (Proxy a) where parseJSON _ = pure Proxy + omittedField = Just Proxy instance FromJSON2 Tagged where - liftParseJSON2 _ _ p _ = fmap Tagged . p + liftParseJSON2 _ _ _ _ p _ = coerce p + liftOmittedField2 _ = coerce instance FromJSON1 (Tagged a) where - liftParseJSON p _ = fmap Tagged . p + liftParseJSON _ p _ = coerce p + liftOmittedField = coerce instance FromJSON b => FromJSON (Tagged a b) where parseJSON = parseJSON1 + omittedField = coerce (omittedField @b) instance FromJSONKey b => FromJSONKey (Tagged a b) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b) @@ -2399,7 +2509,7 @@ -- | @since 1.5.1.0 instance FromJSON a => FromJSON1 (These a) where - liftParseJSON pb _ = withObject "These a b" (p . KM.toList) + liftParseJSON _ pb _ = withObject "These a b" (p . KM.toList) where p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b @@ -2409,7 +2519,7 @@ -- | @since 1.5.1.0 instance FromJSON2 These where - liftParseJSON2 pa _ pb _ = withObject "These a b" (p . KM.toList) + liftParseJSON2 _ pa _ _ pb _ = withObject "These a b" (p . KM.toList) where p [("This", a), ("That", b)] = These <$> pa a <*> pb b p [("That", b), ("This", a)] = These <$> pa a <*> pb b @@ -2419,12 +2529,12 @@ -- | @since 1.5.1.0 instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where - liftParseJSON px pl = withObject "These1" (p . KM.toList) + liftParseJSON o px pl = withObject "These1" (p . KM.toList) where - p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b - p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b - p [("This", a)] = This1 <$> liftParseJSON px pl a - p [("That", b)] = That1 <$> liftParseJSON px pl b + p [("This", a), ("That", b)] = These1 <$> liftParseJSON o px pl a <*> liftParseJSON o px pl b + p [("That", b), ("This", a)] = These1 <$> liftParseJSON o px pl a <*> liftParseJSON o px pl b + p [("This", a)] = This1 <$> liftParseJSON o px pl a + p [("That", b)] = That1 <$> liftParseJSON o px pl b p _ = fail "Expected object with 'This' and 'That' keys only" -- | @since 1.5.1.0 @@ -2451,7 +2561,7 @@ ------------------------------------------------------------------------------- instance FromJSON2 (,) where - liftParseJSON2 pA _ pB _ = withArray "(a, b)" $ \t -> + liftParseJSON2 _ pA _ _ pB _ = withArray "(a, b)" $ \t -> let n = V.length t in if n == 2 then (,) @@ -2460,14 +2570,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2" instance (FromJSON a) => FromJSON1 ((,) a) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b) => FromJSON (a, b) where parseJSON = parseJSON2 instance (FromJSON a) => FromJSON2 ((,,) a) where - liftParseJSON2 pB _ pC _ = withArray "(a, b, c)" $ \t -> + liftParseJSON2 _ pB _ _ pC _ = withArray "(a, b, c)" $ \t -> let n = V.length t in if n == 3 then (,,) @@ -2477,14 +2587,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 3" instance (FromJSON a, FromJSON b) => FromJSON1 ((,,) a b) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a, b, c) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b) => FromJSON2 ((,,,) a b) where - liftParseJSON2 pC _ pD _ = withArray "(a, b, c, d)" $ \t -> + liftParseJSON2 _ pC _ _ pD _ = withArray "(a, b, c, d)" $ \t -> let n = V.length t in if n == 4 then (,,,) @@ -2495,14 +2605,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 4" instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON1 ((,,,) a b c) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a, b, c, d) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON2 ((,,,,) a b c) where - liftParseJSON2 pD _ pE _ = withArray "(a, b, c, d, e)" $ \t -> + liftParseJSON2 _ pD _ _ pE _ = withArray "(a, b, c, d, e)" $ \t -> let n = V.length t in if n == 5 then (,,,,) @@ -2514,14 +2624,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 5" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON1 ((,,,,) a b c d) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a, b, c, d, e) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON2 ((,,,,,) a b c d) where - liftParseJSON2 pE _ pF _ = withArray "(a, b, c, d, e, f)" $ \t -> + liftParseJSON2 _ pE _ _ pF _ = withArray "(a, b, c, d, e, f)" $ \t -> let n = V.length t in if n == 6 then (,,,,,) @@ -2534,14 +2644,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 6" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON1 ((,,,,,) a b c d e) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a, b, c, d, e, f) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON2 ((,,,,,,) a b c d e) where - liftParseJSON2 pF _ pG _ = withArray "(a, b, c, d, e, f, g)" $ \t -> + liftParseJSON2 _ pF _ _ pG _ = withArray "(a, b, c, d, e, f, g)" $ \t -> let n = V.length t in if n == 7 then (,,,,,,) @@ -2555,14 +2665,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 7" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON1 ((,,,,,,) a b c d e f) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a, b, c, d, e, f, g) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON2 ((,,,,,,,) a b c d e f) where - liftParseJSON2 pG _ pH _ = withArray "(a, b, c, d, e, f, g, h)" $ \t -> + liftParseJSON2 _ pG _ _ pH _ = withArray "(a, b, c, d, e, f, g, h)" $ \t -> let n = V.length t in if n == 8 then (,,,,,,,) @@ -2577,14 +2687,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 8" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON1 ((,,,,,,,) a b c d e f g) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON (a, b, c, d, e, f, g, h) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON2 ((,,,,,,,,) a b c d e f g) where - liftParseJSON2 pH _ pI _ = withArray "(a, b, c, d, e, f, g, h, i)" $ \t -> + liftParseJSON2 _ pH _ _ pI _ = withArray "(a, b, c, d, e, f, g, h, i)" $ \t -> let n = V.length t in if n == 9 then (,,,,,,,,) @@ -2600,14 +2710,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 9" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON1 ((,,,,,,,,) a b c d e f g h) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON (a, b, c, d, e, f, g, h, i) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON2 ((,,,,,,,,,) a b c d e f g h) where - liftParseJSON2 pI _ pJ _ = withArray "(a, b, c, d, e, f, g, h, i, j)" $ \t -> + liftParseJSON2 _ pI _ _ pJ _ = withArray "(a, b, c, d, e, f, g, h, i, j)" $ \t -> let n = V.length t in if n == 10 then (,,,,,,,,,) @@ -2624,14 +2734,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 10" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON1 ((,,,,,,,,,) a b c d e f g h i) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON (a, b, c, d, e, f, g, h, i, j) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON2 ((,,,,,,,,,,) a b c d e f g h i) where - liftParseJSON2 pJ _ pK _ = withArray "(a, b, c, d, e, f, g, h, i, j, k)" $ \t -> + liftParseJSON2 _ pJ _ _ pK _ = withArray "(a, b, c, d, e, f, g, h, i, j, k)" $ \t -> let n = V.length t in if n == 11 then (,,,,,,,,,,) @@ -2649,14 +2759,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 11" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON1 ((,,,,,,,,,,) a b c d e f g h i j) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON (a, b, c, d, e, f, g, h, i, j, k) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where - liftParseJSON2 pK _ pL _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l)" $ \t -> + liftParseJSON2 _ pK _ _ pL _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l)" $ \t -> let n = V.length t in if n == 12 then (,,,,,,,,,,,) @@ -2675,14 +2785,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 12" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON1 ((,,,,,,,,,,,) a b c d e f g h i j k) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where - liftParseJSON2 pL _ pM _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m)" $ \t -> + liftParseJSON2 _ pL _ _ pM _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m)" $ \t -> let n = V.length t in if n == 13 then (,,,,,,,,,,,,) @@ -2702,14 +2812,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 13" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where - liftParseJSON2 pM _ pN _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n)" $ \t -> + liftParseJSON2 _ pM _ _ pN _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n)" $ \t -> let n = V.length t in if n == 14 then (,,,,,,,,,,,,,) @@ -2730,14 +2840,14 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 14" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where parseJSON = parseJSON2 instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where - liftParseJSON2 pN _ pO _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)" $ \t -> + liftParseJSON2 _ pN _ _ pO _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)" $ \t -> let n = V.length t in if n == 15 then (,,,,,,,,,,,,,,) @@ -2759,7 +2869,7 @@ else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 15" instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where - liftParseJSON = liftParseJSON2 parseJSON parseJSONList + liftParseJSON = liftParseJSON2 omittedField parseJSON parseJSONList instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n, FromJSON o) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where parseJSON = parseJSON2 diff --git a/src/Data/Aeson/Types/Generic.hs b/src/Data/Aeson/Types/Generic.hs --- a/src/Data/Aeson/Types/Generic.hs +++ b/src/Data/Aeson/Types/Generic.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -36,7 +35,6 @@ , (:*)(..) ) where -import Prelude.Compat import Data.Kind (Type) import GHC.Generics diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -2,17 +2,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} -#if __GLASGOW_HASKELL__ >= 800 --- a) THQ works on cross-compilers and unregisterised GHCs --- b) may make compilation faster as no dynamic loading is ever needed (not sure about this) --- c) removes one hindrance to have code inferred as SafeHaskell safe {-# LANGUAGE TemplateHaskellQuotes #-} -#else -{-# LANGUAGE TemplateHaskell #-} -#endif -- | -- Module: Data.Aeson.Types.Internal @@ -65,6 +57,7 @@ , constructorTagModifier , allNullaryToStringTag , omitNothingFields + , allowOmittedFields , sumEncoding , unwrapUnaryRecords , tagSingleConstructors @@ -81,30 +74,24 @@ , camelTo , camelTo2 + -- * Aeson Exception + , AesonException (..) + -- * Other types , DotNetTime(..) ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude -import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData(..)) +import Control.Exception (Exception (..)) import Control.Monad (MonadPlus(..), ap) -import Control.Monad.Fix (MonadFix (..)) import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum) import Data.Aeson.Key (Key) -import Data.Data (Data) -import Data.Foldable (foldl') import Data.Hashable (Hashable(..)) import Data.List (intercalate) -import Data.Scientific (Scientific) -import Data.String (IsString(..)) -import Data.Text (Text, pack, unpack) -import Data.Time (UTCTime) +import Data.Text (pack, unpack) import Data.Time.Format (FormatTime) -import Data.Typeable (Typeable) -import Data.Vector (Vector) -import GHC.Generics (Generic) import Data.Aeson.KeyMap (KeyMap) import qualified Control.Monad as Monad import qualified Control.Monad.Fail as Fail @@ -125,18 +112,18 @@ | Index {-# UNPACK #-} !Int -- ^ JSON path element of an index into an -- array, \"array[index]\". - deriving (Eq, Show, Typeable, Ord) + deriving (Eq, Show, Ord) type JSONPath = [JSONPathElement] -- | The internal result of running a 'Parser'. data IResult a = IError JSONPath String | ISuccess a - deriving (Eq, Show, Typeable) + deriving (Eq, Show) -- | The result of running a 'Parser'. data Result a = Error String | Success a - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance NFData JSONPathElement where rnf (Key t) = rnf t @@ -382,7 +369,7 @@ | Number !Scientific | Bool !Bool | Null - deriving (Eq, Read, Typeable, Data, Generic) + deriving (Eq, Read, Data, Generic) -- | Since version 1.5.6.0 version object values are printed in lexicographic key order -- @@ -453,11 +440,13 @@ arbValue :: Int -> QC.Gen Value arbValue n - | n <= 0 = QC.oneof + | n <= 1 = QC.oneof [ pure Null , Bool <$> QC.arbitrary , String <$> arbText , Number <$> arbScientific + , pure emptyObject + , pure emptyArray ] | otherwise = QC.oneof @@ -516,7 +505,7 @@ newtype DotNetTime = DotNetTime { fromDotNetTime :: UTCTime -- ^ Acquire the underlying value. - } deriving (Eq, Ord, Read, Show, Typeable, FormatTime) + } deriving (Eq, Ord, Read, Show, FormatTime) instance NFData Value where rnf (Object o) = rnf o @@ -563,8 +552,12 @@ emptyArray :: Value emptyArray = Array V.empty --- | Determines if the 'Value' is an empty 'Array'. --- Note that: @isEmptyArray 'emptyArray'@. +-- | Determines whether the 'Value' is an empty 'Array'. +-- +-- Do note that if this is `False`, the `Value` may be a non-empty +-- array, or it may not even be an array. +-- +-- @since 2.3.1.0 isEmptyArray :: Value -> Bool isEmptyArray (Array arr) = V.null arr isEmptyArray _ = False @@ -730,50 +723,16 @@ -- omitted from the resulting object. If 'False', the resulting -- object will include those fields mapping to @null@. -- - -- Note that this /does not/ affect parsing: 'Maybe' fields are - -- optional regardless of the value of 'omitNothingFields', subject - -- to the note below. - -- - -- === Note - -- - -- Setting 'omitNothingFields' to 'True' only affects fields which are of - -- type 'Maybe' /uniformly/ in the 'ToJSON' instance. - -- In particular, if the type of a field is declared as a type variable, it - -- will not be omitted from the JSON object, unless the field is - -- specialized upfront in the instance. - -- - -- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance. - -- - -- ==== __Example__ - -- - -- The generic instance for the following type @Fruit@ depends on whether - -- the instance head is @Fruit a@ or @Fruit (Maybe a)@. - -- - -- @ - -- data Fruit a = Fruit - -- { apples :: a -- A field whose type is a type variable. - -- , oranges :: 'Maybe' Int - -- } deriving 'Generic' - -- - -- -- apples required, oranges optional - -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)). - -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) - -- - -- -- apples optional, oranges optional - -- -- In this instance, the field apples is uniformly of type ('Maybe' a). - -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) - -- - -- options :: 'Options' - -- options = 'defaultOptions' { 'omitNothingFields' = 'True' } - -- - -- -- apples always present in the output, oranges is omitted if 'Nothing' - -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where - -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options + -- In @aeson-2.2@ this flag is generalised to omit all values with @'Data.Aeson.Types.omitField' x = True@. + -- If 'False', the resulting object will include those fields encoded as specified. -- - -- -- both apples and oranges are omitted if 'Nothing' - -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where - -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options - -- @ + -- Note that this /does not/ affect parsing: 'Maybe' fields are + -- optional regardless of the value of 'omitNothingFields'. + -- 'allowOmittedFieds' controls parsing behavior. + , allowOmittedFields :: Bool + -- ^ If 'True', missing fields of a record will be filled + -- with 'omittedField' values (if they are 'Just'). + -- If 'False', all fields will required to present in the record object. , sumEncoding :: SumEncoding -- ^ Specifies how to encode constructors of a sum datatype. , unwrapUnaryRecords :: Bool @@ -789,13 +748,14 @@ } instance Show Options where - show (Options f c a o s u t r) = + show (Options f c a o q s u t r) = "Options {" ++ intercalate ", " [ "fieldLabelModifier =~ " ++ show (f "exampleField") , "constructorTagModifier =~ " ++ show (c "ExampleConstructor") , "allNullaryToStringTag = " ++ show a , "omitNothingFields = " ++ show o + , "allowOmittedFields = " ++ show q , "sumEncoding = " ++ show s , "unwrapUnaryRecords = " ++ show u , "tagSingleConstructors = " ++ show t @@ -878,6 +838,7 @@ -- , 'constructorTagModifier' = id -- , 'allNullaryToStringTag' = True -- , 'omitNothingFields' = False +-- , 'allowOmittedFields' = True -- , 'sumEncoding' = 'defaultTaggedObject' -- , 'unwrapUnaryRecords' = False -- , 'tagSingleConstructors' = False @@ -890,6 +851,7 @@ , constructorTagModifier = id , allNullaryToStringTag = True , omitNothingFields = False + , allowOmittedFields = True , sumEncoding = defaultTaggedObject , unwrapUnaryRecords = False , tagSingleConstructors = False @@ -954,3 +916,16 @@ go2 "" = "" go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs go2 (x:xs) = x : go2 xs + +------------------------------------------------------------------------------- +-- AesonException +------------------------------------------------------------------------------- + +-- | Exception thrown by 'throwDecode' and variants. +-- +-- @since 2.1.2.0 +newtype AesonException = AesonException String + deriving (Show) + +instance Exception AesonException where + displayException (AesonException str) = "aeson: " ++ str diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -1,24 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- TODO: Drop this when we remove support for Data.Attoparsec.Number -{-# OPTIONS_GHC -fno-warn-deprecations #-} - module Data.Aeson.Types.ToJSON ( -- * Core JSON classes @@ -27,9 +25,11 @@ , ToJSON1(..) , toJSON1 , toEncoding1 + , omitField1 , ToJSON2(..) , toJSON2 , toEncoding2 + , omitField2 -- * Generic JSON classes , GToJSON'(..) , ToArgs(..) @@ -49,6 +49,7 @@ -- * Object key-value pairs , KeyValue(..) + , KeyValueOmit(..) , KeyValuePair(..) , FromPairs(..) -- * Functions needed for documentation @@ -57,9 +58,8 @@ , listValue ) where -import Prelude.Compat +import Data.Aeson.Internal.Prelude -import Control.Applicative (Const(..)) import Control.Monad.ST (ST) import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_) import Data.Aeson.Encoding.Internal ((>*<)) @@ -68,9 +68,8 @@ import Data.Aeson.Types.Internal import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM -import Data.Attoparsec.Number (Number(..)) import Data.Bits (unsafeShiftR) -import Data.Coerce (coerce) +import Data.Complex (Complex(..)) import Data.DList (DList) import Data.Fixed (Fixed, HasResolution, Nano) import Data.Foldable (toList) @@ -80,16 +79,15 @@ import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) import Data.Functor.These (These1 (..)) -import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Proxy (Proxy(..)) +import Data.Maybe (isNothing) +import Data.Ord (Down (..)) import Data.Ratio (Ratio, denominator, numerator) -import Data.Scientific (Scientific) import Data.Tagged (Tagged(..)) -import Data.Text (Text, pack) import Data.These (These (..)) -import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, ZonedTime) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) @@ -97,24 +95,15 @@ import Data.Time.Clock.System.Compat (SystemTime (..)) import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale) import Data.Tuple.Solo (Solo (..), getSolo) -import Data.Vector (Vector) import Data.Version (Version, showVersion) -import Data.Void (Void, absurd) -import Data.Word (Word16, Word32, Word64, Word8) import Foreign.Storable (Storable) import Foreign.C.Types (CTime (..)) import GHC.Generics -#if !MIN_VERSION_base(4,17,0) -import GHC.Generics.Generically (Generically (..), Generically1 (..)) -#endif -import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding, key) import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList -#if MIN_VERSION_dlist(1,0,0) import qualified Data.DList.DNonEmpty as DNE -#endif import qualified Data.Fix as F import qualified Data.HashMap.Strict as H import qualified Data.HashSet as HashSet @@ -140,6 +129,7 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU +import qualified Network.URI as URI import qualified Data.Aeson.Encoding.Builder as EB import qualified Data.ByteString.Builder as B @@ -151,7 +141,7 @@ import qualified Data.Primitive.PrimArray as PM toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value -toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b) +toJSONPair a b = liftToJSON2 (const False) a (listValue a) (const False) b (listValue b) realFloatToJSON :: RealFloat a => a -> Value realFloatToJSON d @@ -176,12 +166,12 @@ -- 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 +-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the three -- function arguments that encode occurrences of the type parameter (for -- 'ToJSON1'). data ToArgs res arity a where NoToArgs :: ToArgs res Zero a - To1Args :: (a -> res) -> ([a] -> res) -> ToArgs res One a + To1Args :: (a -> Bool) -> (a -> res) -> ([a] -> res) -> ToArgs res One a -- | A configurable generic JSON creator. This function applied to -- 'defaultOptions' is used as the default for 'toJSON' when the type @@ -194,9 +184,9 @@ -- 'defaultOptions' is used as the default for 'liftToJSON' when the type -- is an instance of 'Generic1'. genericLiftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f)) - => Options -> (a -> Value) -> ([a] -> Value) + => Options -> (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> f a -> Value -genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1 +genericLiftToJSON opts o tj tjl = gToJSON opts (To1Args o tj tjl) . from1 -- | A configurable generic JSON encoder. This function applied to -- 'defaultOptions' is used as the default for 'toEncoding' when the type @@ -209,9 +199,9 @@ -- 'defaultOptions' is used as the default for 'liftToEncoding' when the type -- is an instance of 'Generic1'. genericLiftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f)) - => Options -> (a -> Encoding) -> ([a] -> Encoding) + => Options -> (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding -genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1 +genericLiftToEncoding opts o te tel = gToJSON opts (To1Args o te tel) . from1 ------------------------------------------------------------------------------- -- Class @@ -323,7 +313,6 @@ -- instance 'ToJSON' Coord where -- 'toEncoding' = 'genericToEncoding' 'defaultOptions' -- @ - toEncoding :: a -> Encoding toEncoding = E.value . toJSON @@ -333,6 +322,14 @@ toEncodingList :: [a] -> Encoding toEncodingList = listEncoding toEncoding + -- | Defines when it is acceptable to omit a field of this type from a record. + -- Used by @('.?=')@ operator, and Generics and TH deriving + -- with @'omitNothingFields' = True@. + -- + -- @since 2.2.0.0 + omitField :: a -> Bool + omitField = const False + -- | @since 2.1.0.0 instance (Generic a, GToJSON' Value Zero (Rep a), GToJSON' Encoding Zero (Rep a)) => ToJSON (Generically a) where toJSON = coerce (genericToJSON defaultOptions :: a -> Value) @@ -343,25 +340,62 @@ ------------------------------------------------------------------------------- -- | A key-value pair for encoding a JSON object. -class KeyValue kv where +class KeyValue e kv | kv -> e where + (.=) :: ToJSON v => Key -> v -> kv infixr 8 .= -instance KeyValue Series where - name .= value = E.pair name (toEncoding value) + -- | @since 2.2.0.0 + explicitToField :: (v -> e) -> Key -> v -> kv + +instance KeyValue Encoding Series where + (.=) = explicitToField toEncoding {-# INLINE (.=) #-} -instance (key ~ Key, value ~ Value) => KeyValue (key, value) where - name .= value = (name, toJSON value) + explicitToField f name value = E.pair name (f value) + {-# INLINE explicitToField #-} + +instance (key ~ Key, value ~ Value) => KeyValue Value (key, value) where + (.=) = explicitToField toJSON {-# INLINE (.=) #-} + explicitToField f name value = (name, f value) + {-# INLINE explicitToField #-} + -- | Constructs a singleton 'KM.KeyMap'. For calling functions that -- demand an 'Object' for constructing objects. To be used in -- conjunction with 'mconcat'. Prefer to use 'object' where possible. -instance value ~ Value => KeyValue (KM.KeyMap value) where - name .= value = KM.singleton name (toJSON value) +instance value ~ Value => KeyValue Value (KM.KeyMap value) where + (.=) = explicitToField toJSON {-# INLINE (.=) #-} + explicitToField f name value = KM.singleton name (f value) + {-# INLINE explicitToField #-} + +-- | An optional key-value pair for encoding to a JSON object +-- +-- @since 2.2.0.0 +-- +class KeyValue e kv => KeyValueOmit e kv | kv -> e where + (.?=) :: ToJSON v => Key -> v -> kv + infixr 8 .?= + + explicitToFieldOmit :: (v -> Bool) -> (v -> e) -> Key -> v -> kv + +instance KeyValueOmit Encoding Series where + name .?= value = if omitField value then mempty else name .= value + {-# INLINE (.?=) #-} + + explicitToFieldOmit o f name value = if o value then mempty else explicitToField f name value + {-# INLINE explicitToFieldOmit #-} + +instance value ~ Value => KeyValueOmit Value (KM.KeyMap value) where + name .?= value = if omitField value then KM.empty else name .= value + {-# INLINE (.?=) #-} + + explicitToFieldOmit o f name value = if o value then KM.empty else explicitToField f name value + {-# INLINE explicitToFieldOmit #-} + ------------------------------------------------------------------------------- -- Classes and types for map keys ------------------------------------------------------------------------------- @@ -613,43 +647,50 @@ -- -- See also 'ToJSON'. class ToJSON1 f where - liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value + liftToJSON :: (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> f a -> Value default liftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f)) - => (a -> Value) -> ([a] -> Value) -> f a -> Value + => (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> f a -> Value liftToJSON = genericLiftToJSON defaultOptions - liftToJSONList :: (a -> Value) -> ([a] -> Value) -> [f a] -> Value - liftToJSONList f g = listValue (liftToJSON f g) + liftToJSONList :: (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> [f a] -> Value + liftToJSONList o f g = listValue (liftToJSON o f g) - liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding + liftToEncoding :: (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding default liftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f)) - => (a -> Encoding) -> ([a] -> Encoding) + => (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding liftToEncoding = genericLiftToEncoding defaultOptions - liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding - liftToEncodingList f g = listEncoding (liftToEncoding f g) + liftToEncodingList :: (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding + liftToEncodingList o f g = listEncoding (liftToEncoding o f g) + -- | @since 2.2.0.0 + liftOmitField :: (a -> Bool) -> f a -> Bool + liftOmitField _ _ = False + -- | @since 2.1.0.0 instance (Generic1 f, GToJSON' Value One (Rep1 f), GToJSON' Encoding One (Rep1 f)) => ToJSON1 (Generically1 f) where - liftToJSON :: forall a. (a -> Value) -> ([a] -> Value) -> Generically1 f a -> Value - liftToJSON = coerce (genericLiftToJSON defaultOptions :: (a -> Value) -> ([a] -> Value) -> f a -> Value) + liftToJSON :: forall a. (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> Generically1 f a -> Value + liftToJSON = coerce (genericLiftToJSON defaultOptions :: (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> f a -> Value) - liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> Generically1 f a -> Encoding - liftToEncoding = coerce (genericLiftToEncoding defaultOptions :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding) + liftToEncoding :: forall a. (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> Generically1 f a -> Encoding + liftToEncoding = coerce (genericLiftToEncoding defaultOptions :: (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding) -- | Lift the standard 'toJSON' function through the type constructor. toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value -toJSON1 = liftToJSON toJSON toJSONList +toJSON1 = liftToJSON omitField toJSON toJSONList {-# INLINE toJSON1 #-} -- | Lift the standard 'toEncoding' function through the type constructor. toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding -toEncoding1 = liftToEncoding toEncoding toEncodingList +toEncoding1 = liftToEncoding omitField toEncoding toEncodingList {-# INLINE toEncoding1 #-} +omitField1 :: (ToJSON1 f, ToJSON a) => f a -> Bool +omitField1 = liftOmitField omitField + -- | Lifting of the 'ToJSON' class to binary type constructors. -- -- Instead of manually writing your 'ToJSON2' instance, "Data.Aeson.TH" @@ -658,24 +699,32 @@ -- The compiler cannot provide a default generic implementation for 'liftToJSON2', -- unlike 'toJSON' and 'liftToJSON'. class ToJSON2 f where - liftToJSON2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value - liftToJSONList2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value - liftToJSONList2 fa ga fb gb = listValue (liftToJSON2 fa ga fb gb) + liftToJSON2 :: (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> (b -> Bool) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value + liftToJSONList2 :: (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> (b -> Bool) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value + liftToJSONList2 oa fa ga ob fb gb = listValue (liftToJSON2 oa fa ga ob fb gb) - liftToEncoding2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> f a b -> Encoding - liftToEncodingList2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> [f a b] -> Encoding - liftToEncodingList2 fa ga fb gb = listEncoding (liftToEncoding2 fa ga fb gb) + liftToEncoding2 :: (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> (b -> Bool) -> (b -> Encoding) -> ([b] -> Encoding) -> f a b -> Encoding + liftToEncodingList2 :: (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> (b -> Bool) -> (b -> Encoding) -> ([b] -> Encoding) -> [f a b] -> Encoding + liftToEncodingList2 oa fa ga ob fb gb = listEncoding (liftToEncoding2 oa fa ga ob fb gb) + -- | @since 2.2.0.0 + liftOmitField2 :: (a -> Bool) -> (b -> Bool) -> f a b -> Bool + liftOmitField2 _ _ _ = False + -- | Lift the standard 'toJSON' function through the type constructor. toJSON2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Value -toJSON2 = liftToJSON2 toJSON toJSONList toJSON toJSONList +toJSON2 = liftToJSON2 omitField toJSON toJSONList omitField toJSON toJSONList {-# INLINE toJSON2 #-} -- | Lift the standard 'toEncoding' function through the type constructor. toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding -toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList +toEncoding2 = liftToEncoding2 omitField toEncoding toEncodingList omitField toEncoding toEncodingList {-# INLINE toEncoding2 #-} +omitField2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Bool +omitField2 = liftOmitField2 omitField omitField +{-# INLINE omitField2 #-} + ------------------------------------------------------------------------------- -- Encoding functions ------------------------------------------------------------------------------- @@ -710,9 +759,9 @@ -- These are needed for key-class default definitions instance ToJSON1 [] where - liftToJSON _ to' = to' + liftToJSON _ _ to' = to' - liftToEncoding _ to' = to' + liftToEncoding _ _ to' = to' instance (ToJSON a) => ToJSON [a] where {-# SPECIALIZE instance ToJSON String #-} @@ -736,7 +785,7 @@ 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 + gToJSON _opts (To1Args _ tj _) = tj . unPar1 -- TODO {-# INLINE gToJSON #-} instance ( ConsToJSON enc arity a @@ -790,7 +839,7 @@ 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 + gToJSON _opts (To1Args o tj tjl) = liftToJSON o tj tjl . unRec1 {-# INLINE gToJSON #-} instance GToJSON' Value arity U1 where @@ -824,7 +873,7 @@ -- instance to generically encode the innermost type: gToJSON opts targs = let gtj = gToJSON opts targs in - liftToJSON gtj (listValue gtj) . unComp1 + liftToJSON (const False) gtj (listValue gtj) . unComp1 {-# INLINE gToJSON #-} -------------------------------------------------------------------------------- @@ -844,7 +893,7 @@ instance ToJSON1 f => GToJSON' Encoding One (Rec1 f) where -- Recursive occurrences of the last type parameter are encoded using their -- ToEncoding1 instance: - gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1 + gToJSON _opts (To1Args o te tel) = liftToEncoding o te tel . unRec1 {-# INLINE gToJSON #-} instance GToJSON' Encoding arity U1 where @@ -871,7 +920,7 @@ -- instance to generically encode the innermost type: gToJSON opts targs = let gte = gToJSON opts targs in - liftToEncoding gte (listEncoding gte) . unComp1 + liftToEncoding (const False) gte (listEncoding gte) . unComp1 {-# INLINE gToJSON #-} -------------------------------------------------------------------------------- @@ -881,7 +930,7 @@ -> f a -> Tagged allNullary enc instance ( GetConName f - , FromString enc + , IsString enc , TaggedObject enc arity f , SumToJSON' ObjectWithSingleField enc arity f , SumToJSON' TwoElemArray enc arity f @@ -930,15 +979,8 @@ -------------------------------------------------------------------------------- -class FromString enc where - fromString :: String -> enc -instance FromString Encoding where - fromString = toEncoding -instance FromString Value where - fromString = String . pack - -------------------------------------------------------------------------------- class TaggedObject enc arity f where @@ -959,7 +1001,7 @@ instance ( IsRecord a isRecord , TaggedObject' enc pairs arity a isRecord , FromPairs enc pairs - , FromString enc + , IsString enc , KeyValuePair enc pairs , Constructor c ) => TaggedObject enc arity (C1 c a) @@ -1047,7 +1089,7 @@ ) => 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 + VM.unsafeWrite mv 0 $ String $ T.pack $ constructorTagModifier opts $ conName (undefined :: t c a p) VM.unsafeWrite mv 1 $ gToJSON opts targs x return mv @@ -1129,50 +1171,54 @@ {-# INLINE recordToPairs #-} instance ( Selector s - , GToJSON' enc arity a + , GToJSON' enc arity (K1 i t) , KeyValuePair enc pairs - ) => RecordToPairs enc pairs arity (S1 s a) + , ToJSON t + ) => RecordToPairs enc pairs arity (S1 s (K1 i t)) where - recordToPairs = fieldToPair + recordToPairs opts targs m1 + | omitNothingFields opts + , omitField (unK1 $ unM1 m1 :: t) + = mempty + + | otherwise = + let key = Key.fromString $ fieldLabelModifier opts (selName m1) + value = gToJSON opts targs (unM1 m1) + in key `pair` value {-# INLINE recordToPairs #-} -instance {-# INCOHERENT #-} - ( Selector s - , GToJSON' enc arity (K1 i (Maybe a)) - , KeyValuePair enc pairs - , Monoid pairs - ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a))) +instance ( Selector s + , GToJSON' enc One (Rec1 f) + , KeyValuePair enc pairs + , ToJSON1 f + ) => RecordToPairs enc pairs One (S1 s (Rec1 f)) where - recordToPairs opts _ (M1 k1) | omitNothingFields opts - , K1 Nothing <- k1 = mempty - recordToPairs opts targs m1 = fieldToPair opts targs m1 + recordToPairs opts targs@(To1Args o _ _) m1 + | omitNothingFields opts + , liftOmitField o $ unRec1 $ unM1 m1 + = mempty + + | otherwise = + let key = Key.fromString $ fieldLabelModifier opts (selName m1) + value = gToJSON opts targs (unM1 m1) + in key `pair` value {-# INLINE recordToPairs #-} -#if !MIN_VERSION_base(4,16,0) -instance {-# INCOHERENT #-} - ( Selector s - , GToJSON' enc arity (K1 i (Maybe a)) - , KeyValuePair enc pairs - , Monoid pairs - ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a))) +instance ( Selector s + , GToJSON' enc One Par1 + , KeyValuePair enc pairs + ) => RecordToPairs enc pairs One (S1 s Par1) where - recordToPairs opts targs = recordToPairs opts targs . unwrap - where - unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p - unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a) - {-# INLINE recordToPairs #-} -#endif + recordToPairs opts targs@(To1Args o _ _) m1 + | omitNothingFields opts + , o (unPar1 (unM1 m1)) + = mempty -fieldToPair :: (Selector s - , GToJSON' enc arity a - , KeyValuePair enc pairs) - => Options -> ToArgs enc arity p - -> S1 s a p -> pairs -fieldToPair opts targs m1 = - let key = Key.fromString $ fieldLabelModifier opts (selName m1) - value = gToJSON opts targs (unM1 m1) - in key `pair` value -{-# INLINE fieldToPair #-} + | otherwise = + let key = Key.fromString $ fieldLabelModifier opts (selName m1) + value = gToJSON opts targs (unM1 m1) + in key `pair` value + {-# INLINE recordToPairs #-} -------------------------------------------------------------------------------- @@ -1251,7 +1297,7 @@ instance {-# OVERLAPPING #-} ( Constructor c - , FromString enc + , IsString enc ) => SumToJSON' UntaggedValue enc arity (C1 c U1) where sumToJSON' opts _ _ = Tagged . fromString $ @@ -1267,43 +1313,49 @@ ------------------------------------------------------------------------------- instance ToJSON2 Const where - liftToJSON2 t _ _ _ (Const x) = t x - liftToEncoding2 t _ _ _ (Const x) = t x + liftToJSON2 _ t _ _ _ _ (Const x) = t x + liftToEncoding2 _ t _ _ _ _ (Const x) = t x + liftOmitField2 o _ (Const x) = o x instance ToJSON a => ToJSON1 (Const a) where - liftToJSON _ _ (Const x) = toJSON x - liftToEncoding _ _ (Const x) = toEncoding x + liftToJSON _ _ _ (Const x) = toJSON x + liftToEncoding _ _ _ (Const x) = toEncoding x + liftOmitField _ (Const x) = omitField x instance ToJSON a => ToJSON (Const a b) where toJSON (Const x) = toJSON x toEncoding (Const x) = toEncoding x + omitField (Const x) = omitField x instance (ToJSON a, ToJSONKey a) => ToJSONKey (Const a b) where toJSONKey = contramap getConst toJSONKey instance ToJSON1 Maybe where - liftToJSON t _ (Just a) = t a - liftToJSON _ _ Nothing = Null + liftToJSON _ t _ (Just a) = t a + liftToJSON _ _ _ Nothing = Null - liftToEncoding t _ (Just a) = t a - liftToEncoding _ _ Nothing = E.null_ + liftToEncoding _ t _ (Just a) = t a + liftToEncoding _ _ _ Nothing = E.null_ + liftOmitField _ = isNothing + instance (ToJSON a) => ToJSON (Maybe a) where toJSON = toJSON1 + omitField = omitField1 toEncoding = toEncoding1 instance ToJSON2 Either where - liftToJSON2 toA _ _toB _ (Left a) = Object $ KM.singleton "Left" (toA a) - liftToJSON2 _toA _ toB _ (Right b) = Object $ KM.singleton "Right" (toB b) + liftToJSON2 _ toA _ _ _toB _ (Left a) = Object $ KM.singleton "Left" (toA a) + liftToJSON2 _ _toA _ _ toB _ (Right b) = Object $ KM.singleton "Right" (toB b) - liftToEncoding2 toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a - liftToEncoding2 _toA _ toB _ (Right b) = E.pairs $ E.pair "Right" $ toB b + liftToEncoding2 _ toA _ _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a + liftToEncoding2 _ _toA _ _ toB _ (Right b) = E.pairs $ E.pair "Right" $ toB b instance (ToJSON a) => ToJSON1 (Either a) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where toJSON = toJSON2 @@ -1338,6 +1390,7 @@ instance ToJSON () where toJSON _ = emptyArray toEncoding _ = emptyArray_ + omitField _ = True instance ToJSON Char where @@ -1355,15 +1408,6 @@ instance ToJSONKey Double where toJSONKey = toJSONKeyTextEnc E.doubleText - -instance ToJSON Number where - toJSON (D d) = toJSON d - toJSON (I i) = toJSON i - - toEncoding (D d) = toEncoding d - toEncoding (I i) = toEncoding i - - instance ToJSON Float where toJSON = realFloatToJSON toEncoding = E.float @@ -1381,6 +1425,19 @@ "numerator" .= numerator r <> "denominator" .= denominator r +-- | A complex number @x+iy@ is encoded as an array @[x, y]@. +-- +-- @since 2.3.1.0 +instance ToJSON a => ToJSON (Complex a) where + toJSON (i :+ q) = Array $ V.create $ do + mv <- VM.unsafeNew 2 + VM.unsafeWrite mv 0 (toJSON i) + VM.unsafeWrite mv 1 (toJSON q) + return mv + toEncoding (i :+ q) = E.list id + [ toEncoding i + , toEncoding q + ] instance HasResolution a => ToJSON (Fixed a) where toJSON = Number . realToFrac @@ -1499,7 +1556,7 @@ toEncoding = E.lazyText instance ToJSONKey LT.Text where - toJSONKey = toJSONKeyText (LT.toStrict) + toJSONKey = toJSONKeyText LT.toStrict -- | @since 2.0.2.0 instance ToJSON ST.ShortText where @@ -1523,8 +1580,8 @@ ------------------------------------------------------------------------------- instance ToJSON1 NonEmpty where - liftToJSON t _ = listValue t . NE.toList - liftToEncoding t _ = listEncoding t . NE.toList + liftToJSON _ t _ = listValue t . NE.toList + liftToEncoding _ t _ = listEncoding t . NE.toList instance (ToJSON a) => ToJSON (NonEmpty a) where toJSON = toJSON1 @@ -1546,24 +1603,22 @@ ------------------------------------------------------------------------------- instance ToJSON1 DList.DList where - liftToJSON t _ = listValue t . toList - liftToEncoding t _ = listEncoding t . toList + liftToJSON _ t _ = listValue t . toList + liftToEncoding _ t _ = listEncoding t . toList instance (ToJSON a) => ToJSON (DList.DList a) where toJSON = toJSON1 toEncoding = toEncoding1 -#if MIN_VERSION_dlist(1,0,0) -- | @since 1.5.3.0 instance ToJSON1 DNE.DNonEmpty where - liftToJSON t _ = listValue t . DNE.toList - liftToEncoding t _ = listEncoding t . DNE.toList + liftToJSON _ t _ = listValue t . DNE.toList + liftToEncoding _ t _ = listEncoding t . DNE.toList -- | @since 1.5.3.0 instance (ToJSON a) => ToJSON (DNE.DNonEmpty a) where toJSON = toJSON1 toEncoding = toEncoding1 -#endif ------------------------------------------------------------------------------- -- OneTuple @@ -1571,19 +1626,19 @@ -- | @since 2.0.2.0 instance ToJSON1 Solo where - liftToJSON t _ (Solo a) = t a - liftToJSONList _ tl xs = tl (map getSolo xs) + liftToJSON _ t _ (Solo a) = t a + liftToJSONList _ _ tl xs = tl (map getSolo xs) - liftToEncoding t _ (Solo a) = t a - liftToEncodingList _ tl xs = tl (map getSolo xs) + liftToEncoding _ t _ (Solo a) = t a + liftToEncodingList _ _ tl xs = tl (map getSolo xs) -- | @since 2.0.2.0 instance (ToJSON a) => ToJSON (Solo a) where toJSON = toJSON1 - toJSONList = liftToJSONList toJSON toJSONList + toJSONList = liftToJSONList omitField toJSON toJSONList toEncoding = toEncoding1 - toEncodingList = liftToEncodingList toEncoding toEncodingList + toEncodingList = liftToEncodingList omitField toEncoding toEncodingList -- | @since 2.0.2.0 instance (ToJSONKey a) => ToJSONKey (Solo a) where @@ -1595,18 +1650,15 @@ ------------------------------------------------------------------------------- instance ToJSON1 Identity where - liftToJSON t _ (Identity a) = t a - liftToJSONList _ tl xs = tl (map runIdentity xs) + liftToJSON _ t _ (Identity a) = t a + liftToJSONList _ _ tl xs = tl (map runIdentity xs) - liftToEncoding t _ (Identity a) = t a - liftToEncodingList _ tl xs = tl (map runIdentity xs) + liftToEncoding _ t _ (Identity a) = t a + liftToEncodingList _ _ tl xs = tl (map runIdentity xs) -instance (ToJSON a) => ToJSON (Identity a) where - toJSON = toJSON1 - toJSONList = liftToJSONList toJSON toJSONList + liftOmitField o (Identity a) = o a - toEncoding = toEncoding1 - toEncodingList = liftToEncodingList toEncoding toEncodingList +deriving via (a :: Type) instance ToJSON a => ToJSON (Identity a) instance (ToJSONKey a) => ToJSONKey (Identity a) where toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey @@ -1614,58 +1666,60 @@ instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where - liftToJSON tv tvl (Compose x) = liftToJSON g gl x + liftToJSON o tv tvl (Compose x) = liftToJSON (liftOmitField o) g gl x where - g = liftToJSON tv tvl - gl = liftToJSONList tv tvl + g = liftToJSON o tv tvl + gl = liftToJSONList o tv tvl - liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs) + liftToJSONList o te tel xs = liftToJSONList (liftOmitField o) g gl (map getCompose xs) where - g = liftToJSON te tel - gl = liftToJSONList te tel + g = liftToJSON o te tel + gl = liftToJSONList o te tel - liftToEncoding te tel (Compose x) = liftToEncoding g gl x + liftToEncoding o te tel (Compose x) = liftToEncoding (liftOmitField o) g gl x where - g = liftToEncoding te tel - gl = liftToEncodingList te tel + g = liftToEncoding o te tel + gl = liftToEncodingList o te tel - liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs) + liftToEncodingList o te tel xs = liftToEncodingList (liftOmitField o) g gl (map getCompose xs) where - g = liftToEncoding te tel - gl = liftToEncodingList te tel + g = liftToEncoding o te tel + gl = liftToEncodingList o te tel + liftOmitField o (Compose xs)= liftOmitField (liftOmitField o) xs + instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where toJSON = toJSON1 - toJSONList = liftToJSONList toJSON toJSONList + toJSONList = liftToJSONList omitField toJSON toJSONList toEncoding = toEncoding1 - toEncodingList = liftToEncodingList toEncoding toEncodingList - + toEncodingList = liftToEncodingList omitField toEncoding toEncodingList + omitField = omitField1 instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Product f g) where - liftToJSON tv tvl (Pair x y) = liftToJSON2 tx txl ty tyl (x, y) + liftToJSON o tv tvl (Pair x y) = liftToJSON2 (liftOmitField o) tx txl (liftOmitField o) ty tyl (x, y) where - tx = liftToJSON tv tvl - txl = liftToJSONList tv tvl - ty = liftToJSON tv tvl - tyl = liftToJSONList tv tvl + tx = liftToJSON o tv tvl + txl = liftToJSONList o tv tvl + ty = liftToJSON o tv tvl + tyl = liftToJSONList o tv tvl - liftToEncoding te tel (Pair x y) = liftToEncoding2 tx txl ty tyl (x, y) + liftToEncoding o te tel (Pair x y) = liftToEncoding2 (liftOmitField o) tx txl (liftOmitField o) ty tyl (x, y) where - tx = liftToEncoding te tel - txl = liftToEncodingList te tel - ty = liftToEncoding te tel - tyl = liftToEncodingList te tel + tx = liftToEncoding o te tel + txl = liftToEncodingList o te tel + ty = liftToEncoding o te tel + tyl = liftToEncodingList o te tel instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Product f g a) where toJSON = toJSON1 toEncoding = toEncoding1 instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Sum f g) where - liftToJSON tv tvl (InL x) = Object $ KM.singleton "InL" (liftToJSON tv tvl x) - liftToJSON tv tvl (InR y) = Object $ KM.singleton "InR" (liftToJSON tv tvl y) + liftToJSON o tv tvl (InL x) = Object $ KM.singleton "InL" (liftToJSON o tv tvl x) + liftToJSON o tv tvl (InR y) = Object $ KM.singleton "InR" (liftToJSON o tv tvl y) - liftToEncoding te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding te tel x - liftToEncoding te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding te tel y + liftToEncoding o te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding o te tel x + liftToEncoding o te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding o te tel y instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Sum f g a) where toJSON = toJSON1 @@ -1676,8 +1730,8 @@ ------------------------------------------------------------------------------- instance ToJSON1 Seq.Seq where - liftToJSON t _ = listValue t . toList - liftToEncoding t _ = listEncoding t . toList + liftToJSON _ t _ = listValue t . toList + liftToEncoding _ t _ = listEncoding t . toList instance (ToJSON a) => ToJSON (Seq.Seq a) where toJSON = toJSON1 @@ -1685,8 +1739,8 @@ instance ToJSON1 Set.Set where - liftToJSON t _ = listValue t . Set.toList - liftToEncoding t _ = listEncoding t . Set.toList + liftToJSON _ t _ = listValue t . Set.toList + liftToEncoding _ t _ = listEncoding t . Set.toList instance (ToJSON a) => ToJSON (Set.Set a) where toJSON = toJSON1 @@ -1698,15 +1752,15 @@ toEncoding = toEncoding . IntSet.toList instance ToJSON1 IntMap.IntMap where - liftToJSON t tol = liftToJSON to' tol' . IntMap.toList + liftToJSON o t tol = liftToJSON (liftOmitField o) to' tol' . IntMap.toList where - to' = liftToJSON2 toJSON toJSONList t tol - tol' = liftToJSONList2 toJSON toJSONList t tol + to' = liftToJSON2 omitField toJSON toJSONList o t tol + tol' = liftToJSONList2 omitField toJSON toJSONList o t tol - liftToEncoding t tol = liftToEncoding to' tol' . IntMap.toList + liftToEncoding o t tol = liftToEncoding (liftOmitField o) to' tol' . IntMap.toList where - to' = liftToEncoding2 toEncoding toEncodingList t tol - tol' = liftToEncodingList2 toEncoding toEncodingList t tol + to' = liftToEncoding2 omitField toEncoding toEncodingList o t tol + tol' = liftToEncodingList2 omitField toEncoding toEncodingList o t tol instance ToJSON a => ToJSON (IntMap.IntMap a) where toJSON = toJSON1 @@ -1714,11 +1768,11 @@ instance ToJSONKey k => ToJSON1 (M.Map k) where - liftToJSON g _ = case toJSONKey of + liftToJSON _ g _ = case toJSONKey of ToJSONKeyText f _ -> Object . KM.fromMap . mapKeyValO f g ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList - liftToEncoding g _ = case toJSONKey of + liftToEncoding _ g _ = case toJSONKey of ToJSONKeyText _ f -> dict f g M.foldrWithKey ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList where @@ -1731,21 +1785,21 @@ instance ToJSON1 Tree.Tree where - liftToJSON t tol = go + liftToJSON o t tol = go where go (Tree.Node root branches) = - liftToJSON2 t tol to' tol' (root, branches) + liftToJSON2 o t tol (const False) to' tol' (root, branches) - to' = liftToJSON go (listValue go) - tol' = liftToJSONList go (listValue go) + to' = liftToJSON (const False) go (listValue go) + tol' = liftToJSONList (const False) go (listValue go) - liftToEncoding t tol = go + liftToEncoding o t tol = go where go (Tree.Node root branches) = - liftToEncoding2 t tol to' tol' (root, branches) + liftToEncoding2 o t tol (const False) to' tol' (root, branches) - to' = liftToEncoding go (listEncoding go) - tol' = liftToEncodingList go (listEncoding go) + to' = liftToEncoding (const False) go (listEncoding go) + tol' = liftToEncodingList (const False) go (listEncoding go) instance (ToJSON v) => ToJSON (Tree.Tree v) where toJSON = toJSON1 @@ -1768,8 +1822,8 @@ ------------------------------------------------------------------------------- instance ToJSON1 Vector where - liftToJSON t _ = Array . V.map t - liftToEncoding t _ = listEncoding t . V.toList + liftToJSON _ t _ = Array . V.map t + liftToEncoding _ t _ = listEncoding t . V.toList instance (ToJSON a) => ToJSON (Vector a) where {-# SPECIALIZE instance ToJSON Array #-} @@ -1804,8 +1858,8 @@ ------------------------------------------------------------------------------- instance ToJSON1 HashSet.HashSet where - liftToJSON t _ = listValue t . HashSet.toList - liftToEncoding t _ = listEncoding t . HashSet.toList + liftToJSON _ t _ = listValue t . HashSet.toList + liftToEncoding _ t _ = listEncoding t . HashSet.toList instance (ToJSON a) => ToJSON (HashSet.HashSet a) where toJSON = toJSON1 @@ -1813,13 +1867,13 @@ instance ToJSONKey k => ToJSON1 (H.HashMap k) where - liftToJSON g _ = case toJSONKey of + liftToJSON _ g _ = case toJSONKey of ToJSONKeyText f _ -> Object . KM.fromHashMap . mapKeyVal f g ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> KM.HashMap k a -> Encoding - liftToEncoding g _ = case toJSONKey of + liftToEncoding _ g _ = case toJSONKey of ToJSONKeyText _ f -> dict f g H.foldrWithKey ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList where @@ -1834,8 +1888,8 @@ ------------------------------------------------------------------------------- instance ToJSON1 KM.KeyMap where - liftToJSON g _ = Object . fmap g - liftToEncoding g _ = dict E.key g KM.foldrWithKey + liftToJSON _ g _ = Object . fmap g + liftToEncoding _ g _ = dict E.key g KM.foldrWithKey instance (ToJSON v) => ToJSON (KM.KeyMap v) where {-# SPECIALIZE instance ToJSON Object #-} @@ -2027,88 +2081,62 @@ toJSONKey = toJSONKeyTextEnc toEncodingQuarterOfYear ------------------------------------------------------------------------------- --- base Monoid/Semigroup +-- base Down ------------------------------------------------------------------------------- -instance ToJSON1 Monoid.Dual where - liftToJSON t _ = t . Monoid.getDual - liftToEncoding t _ = t . Monoid.getDual - -instance ToJSON a => ToJSON (Monoid.Dual a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - - -instance ToJSON1 Monoid.First where - liftToJSON t to' = liftToJSON t to' . Monoid.getFirst - liftToEncoding t to' = liftToEncoding t to' . Monoid.getFirst - -instance ToJSON a => ToJSON (Monoid.First a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - - -instance ToJSON1 Monoid.Last where - liftToJSON t to' = liftToJSON t to' . Monoid.getLast - liftToEncoding t to' = liftToEncoding t to' . Monoid.getLast - -instance ToJSON a => ToJSON (Monoid.Last a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - +-- | @since 2.2.0.0 +deriving via Identity instance ToJSON1 Down -instance ToJSON1 Semigroup.Min where - liftToJSON t _ (Semigroup.Min x) = t x - liftToEncoding t _ (Semigroup.Min x) = t x +-- | @since 2.2.0.0 +deriving via (a :: Type) instance ToJSON a => ToJSON (Down a) -instance ToJSON a => ToJSON (Semigroup.Min a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +------------------------------------------------------------------------------- +-- base Monoid/Semigroup +------------------------------------------------------------------------------- +deriving via Identity instance ToJSON1 Monoid.Dual +deriving via (a :: Type) instance ToJSON a => ToJSON (Monoid.Dual a) -instance ToJSON1 Semigroup.Max where - liftToJSON t _ (Semigroup.Max x) = t x - liftToEncoding t _ (Semigroup.Max x) = t x +deriving via Maybe instance ToJSON1 Monoid.First +deriving via Maybe a instance ToJSON a => ToJSON (Monoid.First a) -instance ToJSON a => ToJSON (Semigroup.Max a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +deriving via Maybe instance ToJSON1 Monoid.Last +deriving via Maybe a instance ToJSON a => ToJSON (Monoid.Last a) -instance ToJSON1 Semigroup.First where - liftToJSON t _ (Semigroup.First x) = t x - liftToEncoding t _ (Semigroup.First x) = t x +deriving via Identity instance ToJSON1 Semigroup.Min +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Min a) -instance ToJSON a => ToJSON (Semigroup.First a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +deriving via Identity instance ToJSON1 Semigroup.Max +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Max a) +deriving via Identity instance ToJSON1 Semigroup.First +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.First a) -instance ToJSON1 Semigroup.Last where - liftToJSON t _ (Semigroup.Last x) = t x - liftToEncoding t _ (Semigroup.Last x) = t x +deriving via Identity instance ToJSON1 Semigroup.Last +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Last a) -instance ToJSON a => ToJSON (Semigroup.Last a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +deriving via Identity instance ToJSON1 Semigroup.WrappedMonoid +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) +-- | @since 2.2.3.0 +deriving via Identity instance ToJSON1 Semigroup.Sum +-- | @since 2.2.3.0 +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Sum a) -instance ToJSON1 Semigroup.WrappedMonoid where - liftToJSON t _ (Semigroup.WrapMonoid x) = t x - liftToEncoding t _ (Semigroup.WrapMonoid x) = t x +-- | @since 2.2.3.0 +deriving via Identity instance ToJSON1 Semigroup.Product +-- | @since 2.2.3.0 +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Product a) -instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +-- | @since 2.2.3.0 +deriving via Bool instance ToJSON Semigroup.All +-- | @since 2.2.3.0 +deriving via Bool instance ToJSON Semigroup.Any #if !MIN_VERSION_base(4,16,0) -instance ToJSON1 Semigroup.Option where - liftToJSON t to' = liftToJSON t to' . Semigroup.getOption - liftToEncoding t to' = liftToEncoding t to' . Semigroup.getOption - -instance ToJSON a => ToJSON (Semigroup.Option a) where - toJSON = toJSON1 - toEncoding = toEncoding1 +deriving via Maybe instance ToJSON1 Semigroup.Option +deriving via Maybe a instance ToJSON a => ToJSON (Semigroup.Option a) #endif ------------------------------------------------------------------------------- @@ -2117,20 +2145,37 @@ -- | @since 1.5.3.0 instance ToJSON1 f => ToJSON (F.Fix f) where - toJSON = go where go (F.Fix f) = liftToJSON go toJSONList f - toEncoding = go where go (F.Fix f) = liftToEncoding go toEncodingList f + toJSON = go where go (F.Fix f) = liftToJSON omitField go toJSONList f + toEncoding = go where go (F.Fix f) = liftToEncoding omitField go toEncodingList f + omitField = go where go (F.Fix f) = liftOmitField go f -- | @since 1.5.3.0 instance (ToJSON1 f, Functor f) => ToJSON (F.Mu f) where - toJSON = F.foldMu (liftToJSON id (listValue id)) - toEncoding = F.foldMu (liftToEncoding id (listEncoding id)) + toJSON = F.foldMu (liftToJSON (const False) id (listValue id)) + toEncoding = F.foldMu (liftToEncoding (const False) id (listEncoding id)) -- | @since 1.5.3.0 instance (ToJSON1 f, Functor f) => ToJSON (F.Nu f) where - toJSON = F.foldNu (liftToJSON id (listValue id)) - toEncoding = F.foldNu (liftToEncoding id (listEncoding id)) + toJSON = F.foldNu (liftToJSON (const False) id (listValue id)) + toEncoding = F.foldNu (liftToEncoding (const False) id (listEncoding id)) ------------------------------------------------------------------------------- +-- network-uri +------------------------------------------------------------------------------- + +-- | @since 2.2.0.0 +instance ToJSON URI.URI where + toJSON uri = toJSON (URI.uriToString id uri "") + toEncoding = encodeURI + +-- | @since 2.2.0.0 +instance ToJSONKey URI.URI where + toJSONKey = toJSONKeyTextEnc encodeURI + +encodeURI :: URI.URI -> Encoding' a +encodeURI uri = E.string (URI.uriToString id uri "") + +------------------------------------------------------------------------------- -- strict ------------------------------------------------------------------------------- @@ -2141,13 +2186,13 @@ -- | @since 1.5.3.0 instance ToJSON2 S.These where - liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy - liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy + liftToJSON2 oa toa toas ob tob tobs = liftToJSON2 oa toa toas ob tob tobs . S.toLazy + liftToEncoding2 oa toa toas ob tob tobs = liftToEncoding2 oa toa toas ob tob tobs . S.toLazy -- | @since 1.5.3.0 instance ToJSON a => ToJSON1 (S.These a) where - liftToJSON toa tos = liftToJSON toa tos . S.toLazy - liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy + liftToJSON oa toa tos = liftToJSON oa toa tos . S.toLazy + liftToEncoding oa toa tos = liftToEncoding oa toa tos . S.toLazy -- | @since 1.5.3.0 instance (ToJSON a, ToJSON b) => ToJSON (S.Pair a b) where @@ -2156,13 +2201,13 @@ -- | @since 1.5.3.0 instance ToJSON2 S.Pair where - liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy - liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy + liftToJSON2 oa toa toas ob tob tobs = liftToJSON2 oa toa toas ob tob tobs . S.toLazy + liftToEncoding2 oa toa toas ob tob tobs = liftToEncoding2 oa toa toas ob tob tobs . S.toLazy -- | @since 1.5.3.0 instance ToJSON a => ToJSON1 (S.Pair a) where - liftToJSON toa tos = liftToJSON toa tos . S.toLazy - liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy + liftToJSON oa toa tos = liftToJSON oa toa tos . S.toLazy + liftToEncoding oa toa tos = liftToEncoding oa toa tos . S.toLazy -- | @since 1.5.3.0 instance (ToJSON a, ToJSON b) => ToJSON (S.Either a b) where @@ -2171,48 +2216,54 @@ -- | @since 1.5.3.0 instance ToJSON2 S.Either where - liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy - liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy + liftToJSON2 oa toa toas ob tob tobs = liftToJSON2 oa toa toas ob tob tobs . S.toLazy + liftToEncoding2 oa toa toas ob tob tobs = liftToEncoding2 oa toa toas ob tob tobs . S.toLazy -- | @since 1.5.3.0 instance ToJSON a => ToJSON1 (S.Either a) where - liftToJSON toa tos = liftToJSON toa tos . S.toLazy - liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy + liftToJSON oa toa tos = liftToJSON oa toa tos . S.toLazy + liftToEncoding oa toa tos = liftToEncoding oa toa tos . S.toLazy -- | @since 1.5.3.0 instance ToJSON a => ToJSON (S.Maybe a) where toJSON = toJSON . S.toLazy toEncoding = toEncoding . S.toLazy + omitField = omitField . S.toLazy -- | @since 1.5.3.0 instance ToJSON1 S.Maybe where - liftToJSON toa tos = liftToJSON toa tos . S.toLazy - liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy + liftToJSON oa toa tos = liftToJSON oa toa tos . S.toLazy + liftToEncoding oa toa tos = liftToEncoding oa toa tos . S.toLazy + liftOmitField oa = liftOmitField oa . S.toLazy ------------------------------------------------------------------------------- -- tagged ------------------------------------------------------------------------------- instance ToJSON1 Proxy where - liftToJSON _ _ _ = Null - liftToEncoding _ _ _ = E.null_ + liftToJSON _ _ _ _ = Null + liftToEncoding _ _ _ _ = E.null_ + liftOmitField _ _ = True instance ToJSON (Proxy a) where toJSON _ = Null toEncoding _ = E.null_ - + omitField _ = True instance ToJSON2 Tagged where - liftToJSON2 _ _ t _ (Tagged x) = t x - liftToEncoding2 _ _ t _ (Tagged x) = t x + liftToJSON2 _ _ _ _ t _ (Tagged x) = t x + liftToEncoding2 _ _ _ _ t _ (Tagged x) = t x + liftOmitField2 _ = coerce instance ToJSON1 (Tagged a) where - liftToJSON t _ (Tagged x) = t x - liftToEncoding t _ (Tagged x) = t x + liftToJSON _ t _ (Tagged x) = t x + liftToEncoding _ t _ (Tagged x) = t x + liftOmitField = coerce instance ToJSON b => ToJSON (Tagged a b) where toJSON = toJSON1 toEncoding = toEncoding1 + omitField = coerce (omitField @b) instance ToJSONKey b => ToJSONKey (Tagged a b) where toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey @@ -2234,35 +2285,35 @@ -- | @since 1.5.1.0 instance ToJSON2 These where - liftToJSON2 toa _ _tob _ (This a) = object [ "This" .= toa a ] - liftToJSON2 _toa _ tob _ (That b) = object [ "That" .= tob b ] - liftToJSON2 toa _ tob _ (These a b) = object [ "This" .= toa a, "That" .= tob b ] + liftToJSON2 _ toa _ _ _tob _ (This a) = object [ "This" .= toa a ] + liftToJSON2 _ _toa _ _ tob _ (That b) = object [ "That" .= tob b ] + liftToJSON2 _ toa _ _ tob _ (These a b) = object [ "This" .= toa a, "That" .= tob b ] - liftToEncoding2 toa _ _tob _ (This a) = E.pairs $ E.pair "This" (toa a) - liftToEncoding2 _toa _ tob _ (That b) = E.pairs $ E.pair "That" (tob b) - liftToEncoding2 toa _ tob _ (These a b) = E.pairs $ E.pair "This" (toa a) <> E.pair "That" (tob b) + liftToEncoding2 _ toa _ _ _tob _ (This a) = E.pairs $ E.pair "This" (toa a) + liftToEncoding2 _ _toa _ _ tob _ (That b) = E.pairs $ E.pair "That" (tob b) + liftToEncoding2 _ toa _ _ tob _ (These a b) = E.pairs $ E.pair "This" (toa a) <> E.pair "That" (tob b) -- | @since 1.5.1.0 instance ToJSON a => ToJSON1 (These a) where - liftToJSON _tob _ (This a) = object [ "This" .= a ] - liftToJSON tob _ (That b) = object [ "That" .= tob b ] - liftToJSON tob _ (These a b) = object [ "This" .= a, "That" .= tob b ] + liftToJSON _ _tob _ (This a) = object [ "This" .= a ] + liftToJSON _ tob _ (That b) = object [ "That" .= tob b ] + liftToJSON _ tob _ (These a b) = object [ "This" .= a, "That" .= tob b ] - liftToEncoding _tob _ (This a) = E.pairs $ "This" .= a - liftToEncoding tob _ (That b) = E.pairs $ E.pair "That" (tob b) - liftToEncoding tob _ (These a b) = E.pairs $ "This" .= a <> E.pair "That" (tob b) + liftToEncoding _ _tob _ (This a) = E.pairs $ "This" .= a + liftToEncoding _ tob _ (That b) = E.pairs $ E.pair "That" (tob b) + liftToEncoding _ tob _ (These a b) = E.pairs $ "This" .= a <> E.pair "That" (tob b) -- | @since 1.5.1.0 instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where - liftToJSON tx tl (This1 a) = object [ "This" .= liftToJSON tx tl a ] - liftToJSON tx tl (That1 b) = object [ "That" .= liftToJSON tx tl b ] - liftToJSON tx tl (These1 a b) = object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ] + liftToJSON o tx tl (This1 a) = object [ "This" .= liftToJSON o tx tl a ] + liftToJSON o tx tl (That1 b) = object [ "That" .= liftToJSON o tx tl b ] + liftToJSON o tx tl (These1 a b) = object [ "This" .= liftToJSON o tx tl a, "That" .= liftToJSON o tx tl b ] - liftToEncoding tx tl (This1 a) = E.pairs $ E.pair "This" (liftToEncoding tx tl a) - liftToEncoding tx tl (That1 b) = E.pairs $ E.pair "That" (liftToEncoding tx tl b) - liftToEncoding tx tl (These1 a b) = E.pairs $ - pair "This" (liftToEncoding tx tl a) `mappend` - pair "That" (liftToEncoding tx tl b) + liftToEncoding o tx tl (This1 a) = E.pairs $ E.pair "This" (liftToEncoding o tx tl a) + liftToEncoding o tx tl (That1 b) = E.pairs $ E.pair "That" (liftToEncoding o tx tl b) + liftToEncoding o tx tl (These1 a b) = E.pairs $ + pair "This" (liftToEncoding o tx tl a) `mappend` + pair "That" (liftToEncoding o tx tl b) -- | @since 1.5.1.0 instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where @@ -2289,46 +2340,47 @@ ------------------------------------------------------------------------------- instance ToJSON2 (,) where - liftToJSON2 toA _ toB _ (a, b) = Array $ V.create $ do + liftToJSON2 _ toA _ _ toB _ (a, b) = Array $ V.create $ do mv <- VM.unsafeNew 2 VM.unsafeWrite mv 0 (toA a) VM.unsafeWrite mv 1 (toB b) return mv - liftToEncoding2 toA _ toB _ (a, b) = E.list id [toA a, toB b] + liftToEncoding2 _ toA _ _ toB _ (a, b) = E.list id [toA a, toB b] instance (ToJSON a) => ToJSON1 ((,) a) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b) => ToJSON (a, b) where toJSON = toJSON2 toEncoding = toEncoding2 + -- omitField = omitField2 instance (ToJSON a) => ToJSON2 ((,,) a) where - liftToJSON2 toB _ toC _ (a, b, c) = Array $ V.create $ do + liftToJSON2 _ toB _ _ toC _ (a, b, c) = Array $ V.create $ do mv <- VM.unsafeNew 3 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toB b) VM.unsafeWrite mv 2 (toC c) return mv - liftToEncoding2 toB _ toC _ (a, b, c) = E.list id + liftToEncoding2 _ toB _ _ toC _ (a, b, c) = E.list id [ toEncoding a , toB b , toC c ] instance (ToJSON a, ToJSON b) => ToJSON1 ((,,) a b) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b) => ToJSON2 ((,,,) a b) where - liftToJSON2 toC _ toD _ (a, b, c, d) = Array $ V.create $ do + liftToJSON2 _ toC _ _ toD _ (a, b, c, d) = Array $ V.create $ do mv <- VM.unsafeNew 4 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2336,7 +2388,7 @@ VM.unsafeWrite mv 3 (toD d) return mv - liftToEncoding2 toC _ toD _ (a, b, c, d) = E.list id + liftToEncoding2 _ toC _ _ toD _ (a, b, c, d) = E.list id [ toEncoding a , toEncoding b , toC c @@ -2344,15 +2396,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON1 ((,,,) a b c) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON2 ((,,,,) a b c) where - liftToJSON2 toD _ toE _ (a, b, c, d, e) = Array $ V.create $ do + liftToJSON2 _ toD _ _ toE _ (a, b, c, d, e) = Array $ V.create $ do mv <- VM.unsafeNew 5 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2361,7 +2413,7 @@ VM.unsafeWrite mv 4 (toE e) return mv - liftToEncoding2 toD _ toE _ (a, b, c, d, e) = E.list id + liftToEncoding2 _ toD _ _ toE _ (a, b, c, d, e) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2370,15 +2422,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON1 ((,,,,) a b c d) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a, b, c, d, e) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON2 ((,,,,,) a b c d) where - liftToJSON2 toE _ toF _ (a, b, c, d, e, f) = Array $ V.create $ do + liftToJSON2 _ toE _ _ toF _ (a, b, c, d, e, f) = Array $ V.create $ do mv <- VM.unsafeNew 6 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2388,7 +2440,7 @@ VM.unsafeWrite mv 5 (toF f) return mv - liftToEncoding2 toE _ toF _ (a, b, c, d, e, f) = E.list id + liftToEncoding2 _ toE _ _ toF _ (a, b, c, d, e, f) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2398,15 +2450,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON1 ((,,,,,) a b c d e) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a, b, c, d, e, f) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON2 ((,,,,,,) a b c d e) where - liftToJSON2 toF _ toG _ (a, b, c, d, e, f, g) = Array $ V.create $ do + liftToJSON2 _ toF _ _ toG _ (a, b, c, d, e, f, g) = Array $ V.create $ do mv <- VM.unsafeNew 7 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2417,7 +2469,7 @@ VM.unsafeWrite mv 6 (toG g) return mv - liftToEncoding2 toF _ toG _ (a, b, c, d, e, f, g) = E.list id + liftToEncoding2 _ toF _ _ toG _ (a, b, c, d, e, f, g) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2428,15 +2480,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON1 ((,,,,,,) a b c d e f) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a, b, c, d, e, f, g) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON2 ((,,,,,,,) a b c d e f) where - liftToJSON2 toG _ toH _ (a, b, c, d, e, f, g, h) = Array $ V.create $ do + liftToJSON2 _ toG _ _ toH _ (a, b, c, d, e, f, g, h) = Array $ V.create $ do mv <- VM.unsafeNew 8 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2448,7 +2500,7 @@ VM.unsafeWrite mv 7 (toH h) return mv - liftToEncoding2 toG _ toH _ (a, b, c, d, e, f, g, h) = E.list id + liftToEncoding2 _ toG _ _ toH _ (a, b, c, d, e, f, g, h) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2460,15 +2512,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON1 ((,,,,,,,) a b c d e f g) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON (a, b, c, d, e, f, g, h) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON2 ((,,,,,,,,) a b c d e f g) where - liftToJSON2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = Array $ V.create $ do + liftToJSON2 _ toH _ _ toI _ (a, b, c, d, e, f, g, h, i) = Array $ V.create $ do mv <- VM.unsafeNew 9 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2481,7 +2533,7 @@ VM.unsafeWrite mv 8 (toI i) return mv - liftToEncoding2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = E.list id + liftToEncoding2 _ toH _ _ toI _ (a, b, c, d, e, f, g, h, i) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2494,15 +2546,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON1 ((,,,,,,,,) a b c d e f g h) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON (a, b, c, d, e, f, g, h, i) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON2 ((,,,,,,,,,) a b c d e f g h) where - liftToJSON2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = Array $ V.create $ do + liftToJSON2 _ toI _ _ toJ _ (a, b, c, d, e, f, g, h, i, j) = Array $ V.create $ do mv <- VM.unsafeNew 10 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2516,7 +2568,7 @@ VM.unsafeWrite mv 9 (toJ j) return mv - liftToEncoding2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = E.list id + liftToEncoding2 _ toI _ _ toJ _ (a, b, c, d, e, f, g, h, i, j) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2530,15 +2582,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON1 ((,,,,,,,,,) a b c d e f g h i) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON (a, b, c, d, e, f, g, h, i, j) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON2 ((,,,,,,,,,,) a b c d e f g h i) where - liftToJSON2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = Array $ V.create $ do + liftToJSON2 _ toJ _ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = Array $ V.create $ do mv <- VM.unsafeNew 11 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2553,7 +2605,7 @@ VM.unsafeWrite mv 10 (toK k) return mv - liftToEncoding2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = E.list id + liftToEncoding2 _ toJ _ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2568,15 +2620,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON1 ((,,,,,,,,,,) a b c d e f g h i j) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON (a, b, c, d, e, f, g, h, i, j, k) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where - liftToJSON2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = Array $ V.create $ do + liftToJSON2 _ toK _ _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = Array $ V.create $ do mv <- VM.unsafeNew 12 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2592,7 +2644,7 @@ VM.unsafeWrite mv 11 (toL l) return mv - liftToEncoding2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = E.list id + liftToEncoding2 _ toK _ _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2608,15 +2660,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON1 ((,,,,,,,,,,,) a b c d e f g h i j k) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where - liftToJSON2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = Array $ V.create $ do + liftToJSON2 _ toL _ _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = Array $ V.create $ do mv <- VM.unsafeNew 13 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2633,7 +2685,7 @@ VM.unsafeWrite mv 12 (toM m) return mv - liftToEncoding2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = E.list id + liftToEncoding2 _ toL _ _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2650,15 +2702,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where - liftToJSON2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Array $ V.create $ do + liftToJSON2 _ toM _ _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Array $ V.create $ do mv <- VM.unsafeNew 14 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2676,7 +2728,7 @@ VM.unsafeWrite mv 13 (toN n) return mv - liftToEncoding2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = E.list id + liftToEncoding2 _ toM _ _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2694,15 +2746,15 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m) => ToJSON1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m, ToJSON n) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where toJSON = toJSON2 toEncoding = toEncoding2 instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m) => ToJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where - liftToJSON2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Array $ V.create $ do + liftToJSON2 _ toN _ _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Array $ V.create $ do mv <- VM.unsafeNew 15 VM.unsafeWrite mv 0 (toJSON a) VM.unsafeWrite mv 1 (toJSON b) @@ -2721,7 +2773,7 @@ VM.unsafeWrite mv 14 (toO o) return mv - liftToEncoding2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = E.list id + liftToEncoding2 _ toN _ _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = E.list id [ toEncoding a , toEncoding b , toEncoding c @@ -2740,8 +2792,8 @@ ] instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m, ToJSON n) => ToJSON1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where - liftToJSON = liftToJSON2 toJSON toJSONList - liftToEncoding = liftToEncoding2 toEncoding toEncodingList + liftToJSON = liftToJSON2 omitField toJSON toJSONList + liftToEncoding = liftToEncoding2 omitField toEncoding toEncodingList instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m, ToJSON n, ToJSON o) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where toJSON = toJSON2 diff --git a/tests/CastFloat.hs b/tests/CastFloat.hs new file mode 100644 --- /dev/null +++ b/tests/CastFloat.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE CPP #-} +module CastFloat ( + castDoubleToWord64, + castWord64ToDouble, + castFloatTests, +) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (testProperty, (===)) + +import Types (UniformWord64 (..)) + +#if MIN_VERSION_base(4,11,0) +import GHC.Float (castDoubleToWord64, castWord64ToDouble) +#else + +import Data.Word (Word64) +import Foreign.Storable (Storable (peek, poke)) +import Foreign.Ptr (castPtr) +import Foreign.Marshal (alloca) +import System.IO.Unsafe (unsafeDupablePerformIO) + +castDoubleToWord64 :: Double -> Word64 +castDoubleToWord64 = reinterpretCast + +castWord64ToDouble :: Word64 -> Double +castWord64ToDouble = reinterpretCast + +reinterpretCast :: (Storable a, Storable b) => a -> b +reinterpretCast x = unsafeDupablePerformIO $ alloca $ \ptr -> do + poke ptr x + peek (castPtr ptr) + +#endif + +castFloatTests :: TestTree +castFloatTests = testGroup "castDoubleToWord64" + [ testCase "5e-324" $ castDoubleToWord64 5e-324 @?= 1 + , testProperty "roundtrip1" $ \d -> castWord64ToDouble (castDoubleToWord64 d) === d + , testProperty "roundtrip2" $ \(U64 w) -> castDoubleToWord64 (castWord64ToDouble w) === w + ] diff --git a/tests/DoubleToScientific.hs b/tests/DoubleToScientific.hs new file mode 100644 --- /dev/null +++ b/tests/DoubleToScientific.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE UnboxedTuples, BangPatterns, MultiWayIf #-} +module DoubleToScientific ( + doubleToScientific, + doubleToScientificTests, +) where + +-- import Debug.Trace +-- import Data.Ratio ((%)) + +import Data.Bits +import Data.Foldable (foldl') +import Data.Word (Word64) +import Data.Scientific (Scientific) +import GHC.Integer (quotRemInteger) + +import qualified Data.Scientific as Sci + +import CastFloat +import Types (UniformWord64 (..)) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty, counterexample, (===), (==>)) + +------------------------------------------------------------------------------- +-- tests +------------------------------------------------------------------------------- + +-- note: RFC8785 has some special cases. +doubleToScientificTests :: TestTree +doubleToScientificTests = testGroup "doubleToScientific" + [ testProperty "roundtrip1" $ \d -> + Sci.toRealFloat (doubleToScientific d) === d + , testProperty "roundtrip2" $ \(U64 w) -> + let d = castWord64ToDouble w + in counterexample (show d) $ + not (isInfinite d || isNaN d) ==> + Sci.toRealFloat (doubleToScientific d) === d + ] + +------------------------------------------------------------------------------- +-- doubleToScientific +------------------------------------------------------------------------------- + +{- Convert 'Double' to 'Scientific' + +Based on double-conversion implementation +https://github.com/google/double-conversion + +Copyright 2006-2011, the V8 project authors. All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + * Neither the name of Google Inc. nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} +doubleToScientific :: Double -> Scientific +doubleToScientific v = case compare v 0 of + EQ -> 0 + LT -> negate (doubleToScientific' (negate v)) + GT -> doubleToScientific' v + +------------------------------------------------------------------------------- +-- doubleToScientific implementation +------------------------------------------------------------------------------- + +data S = S + { num :: !Integer + , den :: !Integer + , delta_m :: !Integer + , delta_p :: !Integer + , is_even :: !Bool + } + deriving Show + +-- preconditions: v > 0 +doubleToScientific' :: Double -> Scientific +doubleToScientific' v = + let s1 = initialStartValues v + (s2, pow10) = fixupMultiply10 s1 + ds = generateShortestDigits s2 + k = length ds + in Sci.scientific (foldl' (\acc d -> 10 * acc + d) 0 ds) (pow10 - k + 1) + -- error $ show (s1, s2, pow10, fromRational (num s2 % den s2), ds) + +initialStartValues :: Double -> S +initialStartValues v = lowerBoundaryCloser' $ applyExponent e S + { num = shiftL s 1 + , den = 2 + , delta_m = 1 + , delta_p = 1 + , is_even = evenInteger s + } + where + (s, e, lower_boundary_is_closer) = decodeFloat' v + lowerBoundaryCloser' = if lower_boundary_is_closer then lowerBoundaryCloser else id + +-- | return significand, exponent and whether lower boundary is closer. +-- +-- GHC's decodeFloat does "weird" stuff to denormal doubles, +-- that messes up our delta calculation. +decodeFloat' :: Double -> (Integer, Int, Bool) +decodeFloat' d + | denormal = (toInteger s, kDenormalExponent, False) + | otherwise = (toInteger (s .|. kHiddenBit), fromIntegral e - kExponentBias, w64 .&. kSignificandMask == 0) + where + denormal = w64 .&. kExponentMask == 0 + + s = w64 .&. kSignificandMask + e = shiftR (w64 .&. kExponentMask) kPhysicalSignificandSize + + w64 = castDoubleToWord64 d + + kExponentMask = 0x7FF0000000000000 :: Word64 + kSignificandMask = 0x000FFFFFFFFFFFFF :: Word64 + kHiddenBit = 0x0010000000000000 :: Word64 + + kPhysicalSignificandSize = 52 :: Int + kExponentBias = 0x3FF + kPhysicalSignificandSize :: Int + kDenormalExponent = -kExponentBias + 1 :: Int + +lowerBoundaryCloser :: S -> S +lowerBoundaryCloser s = s + { num = shiftL (num s) 1 + , den = shiftL (den s) 1 + , delta_p = shiftL (delta_p s) 1 + } + +applyExponent :: Int -> S -> S +applyExponent e s = case compare e 0 of + EQ -> s + GT -> S + { num = shiftL (num s) e + , den = den s + , delta_m = shiftL (delta_m s) e + , delta_p = shiftL (delta_m s) e + , is_even = is_even s + } + LT -> S + { num = num s + , den = shiftL (den s) (negate e) + , delta_m = delta_m s + , delta_p = delta_m s + , is_even = is_even s + } + +-- This routine multiplies numerator/denominator so that its values lies in the +-- range 1-10. That is after a call to this function we have: +-- 1 <= (numerator + delta_plus) / denominator < 10. +fixupMultiply10 :: S -> (S, Int) +fixupMultiply10 = go 0 where + go p s = case compare (den s) (num s + delta_p s) of + GT -> go (p - 1) (times10 s) + EQ -> (s, p) -- TODO: is_even check? + LT -> case compare (num s + delta_p s) (10 * den s) of + LT -> (s, p) + _ -> go (p + 1) (div10 s) + +times10 :: S -> S +times10 s = s { num = 10 * num s, delta_p = 10 * delta_p s, delta_m = 10 * delta_m s } + +div10 :: S -> S +div10 s = s { den = 10 * den s } + +generateShortestDigits :: S -> [Integer] +generateShortestDigits = go where + go s = case quotRemInteger (num s) (den s) of + (# d, r #) -> if + | not in_delta_room_minus + , not in_delta_room_plus + -> d : go (times10 s { num = r }) + + | in_delta_room_minus + , in_delta_room_plus + -- Let's see if 2*numerator < denominator. + -- If yes, then the next digit would be < 5 and we can round down. + -> case compare (2 * r) (den s) of + -- Remaining digits are less than .5. -> Round down (== do nothing). + LT -> [d] + -- Remaining digits are more than .5 of denominator. -> Round up. + GT -> [d+1] + -- Halfway case. + -- round towards even + EQ -> if evenInteger d then [d] else [d+1] + + | in_delta_room_minus + -- round down + -> [d] + + | otherwise + -- Round up. + -> [d + 1] + + where + in_delta_room_minus + | is_even s = r <= delta_m s + | otherwise = r < delta_m s + + in_delta_room_plus + | is_even s = r + delta_p s >= den s + | otherwise = r + delta_p s > den s + +evenInteger :: Integer -> Bool +evenInteger i = not (testBit i 0) diff --git a/tests/Encoders.hs b/tests/Encoders.hs --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-} module Encoders (module Encoders) where @@ -117,11 +118,11 @@ -- Unary types type LiftToJSON f a = - (a -> Value) -> ([a] -> Value) -> f a -> Value + (a -> Bool) -> (a -> Value) -> ([a] -> Value) -> f a -> Value type LiftToEncoding f a = - (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding + (a -> Bool) -> (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding type LiftParseJSON f a = - (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) + Maybe a -> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a) thSomeTypeToJSON2ElemArray :: SomeType Int -> Value thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType) @@ -295,31 +296,6 @@ thMaybeFieldToJSON :: MaybeField -> Value thMaybeFieldToJSON = $(mkToJSON optsOptionField 'MaybeField) - - --------------------------------------------------------------------------------- --- IncoherentInstancesNeeded --------------------------------------------------------------------------------- - --- | This test demonstrates the need for IncoherentInstances. See the definition --- of 'IncoherentInstancesNeeded' for a discussion of the issue. --- --- NOTE 1: We only need to compile this test. We do not need to run it. --- --- NOTE 2: We actually only use the INCOHERENT pragma on specific instances --- instead of the IncoherentInstances language extension. Therefore, this is --- only supported on GHC versions >= 7.10. -#if __GLASGOW_HASKELL__ >= 710 -incoherentInstancesNeededParseJSONString :: FromJSON a => Value -> Parser (IncoherentInstancesNeeded a) -incoherentInstancesNeededParseJSONString = case () of - _ | True -> $(mkParseJSON defaultOptions ''IncoherentInstancesNeeded) - | False -> genericParseJSON defaultOptions - -incoherentInstancesNeededToJSON :: ToJSON a => IncoherentInstancesNeeded a -> Value -incoherentInstancesNeededToJSON = case () of - _ | True -> $(mkToJSON defaultOptions ''IncoherentInstancesNeeded) - | False -> genericToJSON defaultOptions -#endif ------------------------------------------------------------------------------- -- EitherTextInt encoders/decodes diff --git a/tests/ErrorMessages.hs b/tests/ErrorMessages.hs --- a/tests/ErrorMessages.hs +++ b/tests/ErrorMessages.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module ErrorMessages ( @@ -9,12 +10,11 @@ import Prelude.Compat -import Data.Aeson (FromJSON(..), Value, json) -import Data.Aeson.Types (Parser, formatError, iparse) -import Data.Aeson.Parser (eitherDecodeWith) +import Data.Aeson (FromJSON(..), Value, eitherDecode) +import Data.Aeson.Types (Parser, parseEither) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Proxy (Proxy(..)) -import Data.Semigroup ((<>)) + import Data.Sequence (Seq) import Instances () import Numeric.Natural (Natural) @@ -23,6 +23,10 @@ import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as HM +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + import Encoders import Types @@ -209,8 +213,8 @@ testWith name parser ts = outputLine name <> foldMap (\s -> - case eitherDecodeWith json (iparse parser) s of - Left err -> outputLine $ uncurry formatError err + case eitherDecode s >>= parseEither parser of + Left err -> outputLine err Right a -> outputLine $ show a) ts testFor :: forall a proxy. (FromJSON a, Show a) diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -13,19 +13,26 @@ import Control.Applicative (empty) import Control.Monad +import Data.Maybe (mapMaybe) import Data.Aeson.Types import Data.Function (on) import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..)) import Functions -import Test.QuickCheck (Arbitrary(..), elements, oneof) +import Test.QuickCheck (Arbitrary(..), elements, oneof) import Types import qualified Data.DList as DList import qualified Data.HashMap.Strict as HM +import qualified Network.URI as URI import Data.Orphans () import Test.QuickCheck.Instances () +#if !MIN_VERSION_base(4,16,0) +import Data.Semigroup (Option (..)) +import Data.Tuple.Solo (Solo (..)) +#endif + -- "System" types. instance Arbitrary DotNetTime where @@ -155,9 +162,13 @@ #if !MIN_VERSION_base(4,16,0) instance Arbitrary OptionField where - arbitrary = OptionField <$> arbitrary + arbitrary = OptionField . Option <$> arbitrary #endif +#if !MIN_VERSION_base(4,16,0) && MIN_VERSION_QuickCheck(2,17,0) +instance Arbitrary a => Arbitrary (Solo a) where + arbitrary = MkSolo <$> arbitrary +#endif instance ApproxEq Char where (=~) = (==) @@ -167,3 +178,9 @@ instance Arbitrary a => Arbitrary (DList.DList a) where arbitrary = DList.fromList <$> arbitrary + +instance Arbitrary URI.URI where + arbitrary = elements $ mapMaybe URI.parseURI + [ "https://haskell.org" + , "foo://anonymous@www.haskell.org:42/ghc?query#frag" + ] diff --git a/tests/JSONTestSuite.hs b/tests/JSONTestSuite.hs --- a/tests/JSONTestSuite.hs +++ b/tests/JSONTestSuite.hs @@ -13,12 +13,14 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.HashSet as HashSet +import qualified Data.Text.Encoding as TE import Data.Aeson import qualified Data.Aeson.Decoding as D import Data.Aeson.Decoding.Tokens import qualified Data.Aeson.Decoding.ByteString as D import qualified Data.Aeson.Decoding.ByteString.Lazy as D +import qualified Data.Aeson.Decoding.Text as D jsonTestSuiteTest :: FilePath -> TestTree @@ -57,6 +59,13 @@ let result = D.lbsToTokens payload return (LBS8.pack (unlines (showTokens (const []) result))) + , goldenVsStringDiff "tokens text" diff ("tests" "JSONTestSuite" "results" fileName -<.> "tok") $ do + payload' <- B.readFile path + case TE.decodeUtf8' payload' of + Left exc -> fail $ show exc -- successful test shouldn't fail. + Right payload -> do + let result = D.textToTokens payload + return (LBS8.pack (unlines (showTokens (const []) result))) ] negative = testGroup fileName @@ -74,6 +83,12 @@ let result3 = D.eitherDecode payloadL :: Either String Value assertBool ("lazy:" ++ show result3) (isLeft result3) + case TE.decodeUtf8' payload of + Left _exc -> return () + Right payloadT -> do + let result4 = D.eitherDecodeStrictText payloadT :: Either String Value + assertBool ("text:" ++ show result4) (isLeft result4) + , goldenVsStringDiff "tokens bs" diff ("tests" "JSONTestSuite" "results" fileName -<.> "tok") $ do payload <- B.readFile path let result = D.bsToTokens payload @@ -84,6 +99,15 @@ let result = D.lbsToTokens payload return (LBS8.pack (unlines (showTokens (const []) result))) + , goldenVsStringDiff "tokens text" diff ("tests" "JSONTestSuite" "results" fileName -<.> "ttok") $ do + payload' <- B.readFile path + case TE.decodeUtf8' payload' of + Left _exc -> do + -- some failing cases are invalid UTF8 + return (LBS8.pack "Invalid UTF8") + Right payload -> do + let result = D.textToTokens payload + return (LBS8.pack (unlines (showTokens (const []) result))) ] showTokens :: Show e => (k -> [String]) -> Tokens k e -> [String] diff --git a/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok b/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok --- a/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok +++ b/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok b/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_newline.tok b/tests/JSONTestSuite/results/n_string_unescaped_newline.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_newline.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_newline.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_tab.tok b/tests/JSONTestSuite/results/n_string_unescaped_tab.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_tab.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_tab.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -31,8 +31,7 @@ import Data.Aeson (eitherDecode, encode) import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Parser (value) -import Data.Aeson.Types +import Data.Aeson.Types hiding (isEmptyArray) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.HashMap.Strict (HashMap) @@ -40,10 +39,9 @@ import Data.Map (Map) import Encoders import Instances () -import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample) +import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample, property) import Types import Text.Read (readMaybe) -import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Vector as V import qualified Data.Aeson.Decoding as Dec @@ -51,8 +49,9 @@ encodeDouble :: Double -> Double -> Property encodeDouble num denom - | isInfinite d || isNaN d = encode d === "null" - | otherwise = (read . L.unpack . encode) d === d + | isNaN d = encode d === "null" + | isInfinite d = if d > 0 then encode d === "\"+inf\"" else encode d === "\"-inf\"" + | otherwise = (read . L.unpack . encode) d === d where d = num / denom encodeInteger :: Integer -> Property @@ -73,16 +72,15 @@ -> Property toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson where - parsejson = parsejson1 parseJSON (listParser parseJSON) - tojson = tojson1 toJSON (listValue toJSON) + parsejson = parsejson1 omittedField parseJSON (listParser parseJSON) + tojson = tojson1 omitField toJSON (listValue toJSON) roundTripEnc :: (FromJSON a, ToJSON a, Show a) => (a -> a -> Property) -> a -> Property roundTripEnc eq i = - case fmap ifromJSON . L.parse value . encode $ i of - L.Done _ (ISuccess v) -> v `eq` i - L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i - L.Fail _ _ err -> failure "parse" err i + case eitherDecode . encode $ i of + Right v -> v `eq` i + Left err -> failure "parsing" err i roundTripDecEnc :: (FromJSON a, ToJSON a, Show a) => (a -> a -> Property) -> a -> Property @@ -98,8 +96,23 @@ (ISuccess v) -> v `eq` i (IError path err) -> failure "fromJSON" (formatError path err) i +roundTripOmit :: (FromJSON a, ToJSON a, Show a) => + (Maybe a -> Maybe a -> Property) -> a -> Property +roundTripOmit eq i + | omitField i = omf `eq` Just i + | otherwise = case fmap omitField omf of + Nothing -> property True + Just True -> property True + Just False -> counterexample (show omf) False + where + omf = omittedField + roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> Property -roundTripEq y = roundTripEnc (===) y .&&. roundTripNoEnc (===) y .&&. roundTripDecEnc (===) y +roundTripEq y = + roundTripEnc (===) y .&&. + roundTripNoEnc (===) y .&&. + roundTripDecEnc (===) y .&&. + roundTripOmit (===) y roundtripReadShow :: Value -> Property roundtripReadShow v = readMaybe (show v) === Just v @@ -163,9 +176,9 @@ -> Property sameAs1 toVal1 toEnc1 v = lhs === rhs where - rhs = Right $ toVal1 toJSON (listValue toJSON) v + rhs = Right $ toVal1 omitField toJSON (listValue toJSON) v lhs = eitherDecode . encodingToLazyByteString $ - toEnc1 toEncoding (listEncoding toEncoding) v + toEnc1 omitField toEncoding (listEncoding toEncoding) v sameAs1Agree :: ToJSON a @@ -176,7 +189,7 @@ sameAs1Agree toEnc toEnc1 v = rhs === lhs where rhs = encodingToLazyByteString $ toEnc v - lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v + lhs = encodingToLazyByteString $ toEnc1 omitField toEncoding (listEncoding toEncoding) v -------------------------------------------------------------------------------- -- Value properties diff --git a/tests/PropertyKeys.hs b/tests/PropertyKeys.hs --- a/tests/PropertyKeys.hs +++ b/tests/PropertyKeys.hs @@ -6,6 +6,7 @@ import Prelude.Compat import Control.Applicative (Const) +import Data.Fixed (Fixed, E3, E6) import Data.Time.Compat (Day, LocalTime, TimeOfDay, UTCTime) import Data.Time.Calendar.Compat (DayOfWeek) import Data.Time.Calendar.Month.Compat (Month) @@ -47,4 +48,6 @@ , testProperty "Lazy Text" $ roundTripKey @LT.Text , testProperty "UUID" $ roundTripKey @UUID.UUID , testProperty "Const Text" $ roundTripKey @(Const T.Text ()) + , testProperty "Fixed E3" $ roundTripKey @(Fixed E3) + , testProperty "Fixed E6" $ roundTripKey @(Fixed E6) ] diff --git a/tests/PropertyQC.hs b/tests/PropertyQC.hs --- a/tests/PropertyQC.hs +++ b/tests/PropertyQC.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeApplications #-} diff --git a/tests/PropertyRTFunctors.hs b/tests/PropertyRTFunctors.hs --- a/tests/PropertyRTFunctors.hs +++ b/tests/PropertyRTFunctors.hs @@ -20,7 +20,7 @@ , testProperty "Identity Char" $ roundTripEq @(I Char) , testProperty "Identity [Char]" $ roundTripEq @(I String) - , testProperty "[Identity Char]" $ roundTripEq @([I Char]) + , testProperty "[Identity Char]" $ roundTripEq @[I Char] , testProperty "Compose I I Int" $ roundTripEq @(LogScaled (Compose I I Int)) , testProperty "Compose [] I Int" $ roundTripEq @(LogScaled (Compose [] I Int)) diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs --- a/tests/PropertyRoundTrip.hs +++ b/tests/PropertyRoundTrip.hs @@ -7,6 +7,7 @@ import Control.Applicative (Const) import Data.Aeson.Types +import Data.Complex (Complex(..)) import Data.DList (DList) import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) @@ -23,10 +24,13 @@ import Data.Time.LocalTime.Compat (CalendarDiffTime) import Data.Time.Clock.System.Compat (SystemTime) import Data.Tuple.Solo (Solo) +import Network.URI (URI) import Numeric.Natural (Natural) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Types +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Short as ST @@ -41,8 +45,9 @@ roundTripTests :: TestTree roundTripTests = - testGroup "roundTrip" [ - testProperty "Value" $ roundTripEq @Value + testGroup "roundTrip" + [ testProperty "()" $ roundTripEq @() + , testProperty "Value" $ roundTripEq @Value , testProperty "Bool" $ roundTripEq @Bool , testProperty "Double" $ roundTripEq @(Approx Double) , testProperty "Int" $ roundTripEq @Int @@ -77,17 +82,26 @@ , testProperty "Seq" $ roundTripEq @(Seq Int) , testProperty "Rational" $ roundTripEq @Rational , testProperty "Ratio Int" $ roundTripEq @(Ratio Int) + , testProperty "Complex Float" $ roundTripEq @(Complex Float) + , testProperty "Complex Double" $ roundTripEq @(Complex Double) , testProperty "UUID" $ roundTripEq @UUID.UUID , testProperty "These" $ roundTripEq @(These Char Bool) , testProperty "Fix" $ roundTripEq @(F.Fix (These Char)) , testProperty "Mu" $ roundTripEq @(F.Mu (These Char)) , testProperty "Nu" $ roundTripEq @(F.Nu (These Char)) + , testProperty "Maybe" $ roundTripEq @(Maybe Int) + , testProperty "Monoid.First" $ roundTripEq @(Monoid.First Int) + , testProperty "Semigroup.Sum" $ roundTripEq @(Semigroup.Sum Int) + , testProperty "Semigroup.Product" $ roundTripEq @(Semigroup.Product Int) + , testProperty "Semigroup.All" $ roundTripEq @Semigroup.All + , testProperty "Semigroup.Any" $ roundTripEq @Semigroup.Any , testProperty "Strict Pair" $ roundTripEq @(S.Pair Int Char) , testProperty "Strict Either" $ roundTripEq @(S.Either Int Char) , testProperty "Strict These" $ roundTripEq @(S.These Int Char) , testProperty "Strict Maybe" $ roundTripEq @(S.Maybe Int) , testProperty "Solo Int" $ roundTripEq @(Solo Int) - , testProperty "ShortText" $ roundTripEq @(ST.ShortText) + , testProperty "ShortText" $ roundTripEq @ST.ShortText + , testProperty "URI" $ roundTripEq @URI , roundTripFunctorsTests , testGroup "ghcGenerics" [ testProperty "OneConstructor" $ roundTripEq OneConstructor diff --git a/tests/RFC8785.hs b/tests/RFC8785.hs new file mode 100644 --- /dev/null +++ b/tests/RFC8785.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +module RFC8785 (rfc8785Tests) where + +import Data.Text (Text) +import Data.Word (Word64) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.QuickCheck (testProperty, (===)) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Data.Scientific as Sci + +import Data.Aeson +import Data.Aeson.Decoding.ByteString.Lazy +import Data.Aeson.Decoding.Tokens +import Data.Aeson.QQ.Simple +import Data.Aeson.RFC8785 + +import CastFloat +import DoubleToScientific + +rfc8785Tests :: TestTree +rfc8785Tests = testGroup "RFC8785" + [ testCase "example" $ do + encodeCanonical exampleValue @?= exampleBS + + , testCase "key-sort" $ do + recordTextValues (encodeCanonical sortingValue) @?= sortingStrings + + , numberCases + + , testProperty "roundtrip" $ \v -> + decode (encodeCanonical v) === Just (v :: Value) + + , castFloatTests + , doubleToScientificTests + ] + +------------------------------------------------------------------------------- +-- Example +------------------------------------------------------------------------------- + +exampleValue :: Value +exampleValue = mapNumbers (doubleToScientific . Sci.toRealFloat) [aesonQQ| { + "numbers": [333333333.33333329, 1E30, 4.50, + 2e-3, 0.000000000000000000000000001], + "string": "\u20ac$\u000F\u000aA'\u0042\u0022\u005c\\\"\/", + "literals": [null, true, false] + } |] + +mapNumbers :: (Sci.Scientific -> Sci.Scientific) -> Value -> Value +mapNumbers _ v@Null = v +mapNumbers _ v@(String _) = v +mapNumbers _ v@(Bool _) = v +mapNumbers f (Number x) = Number (f x) +mapNumbers f (Object xs) = Object (fmap (mapNumbers f) xs) +mapNumbers f (Array xs) = Array (fmap (mapNumbers f) xs) + + +exampleBS :: LBS.ByteString +exampleBS = LBS.pack + [ 0x7b, 0x22, 0x6c, 0x69, 0x74, 0x65, 0x72, 0x61, 0x6c, 0x73, 0x22, 0x3a, 0x5b, 0x6e, 0x75, 0x6c, 0x6c, 0x2c, 0x74, 0x72 + , 0x75, 0x65, 0x2c, 0x66, 0x61, 0x6c, 0x73, 0x65, 0x5d, 0x2c, 0x22, 0x6e, 0x75, 0x6d, 0x62, 0x65, 0x72, 0x73, 0x22, 0x3a + , 0x5b, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x2e, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x2c, 0x31 + , 0x65, 0x2b, 0x33, 0x30, 0x2c, 0x34, 0x2e, 0x35, 0x2c, 0x30, 0x2e, 0x30, 0x30, 0x32, 0x2c, 0x31, 0x65, 0x2d, 0x32, 0x37 + , 0x5d, 0x2c, 0x22, 0x73, 0x74, 0x72, 0x69, 0x6e, 0x67, 0x22, 0x3a, 0x22, 0xe2, 0x82, 0xac, 0x24, 0x5c, 0x75, 0x30, 0x30 + , 0x30, 0x66, 0x5c, 0x6e, 0x41, 0x27, 0x42, 0x5c, 0x22, 0x5c, 0x5c, 0x5c, 0x5c, 0x5c, 0x22, 0x2f, 0x22, 0x7d + ] + +------------------------------------------------------------------------------- +-- Key sorting +------------------------------------------------------------------------------- + +sortingValue :: Value +sortingValue = [aesonQQ| { + "\u20ac": "Euro Sign", + "\r": "Carriage Return", + "\ufb33": "Hebrew Letter Dalet With Dagesh", + "1": "One", + "\ud83d\ude00": "Emoji: Grinning Face", + "\u0080": "Control", + "\u00f6": "Latin Small Letter O With Diaeresis" + } |] + +sortingStrings :: [Text] +sortingStrings = + [ "Carriage Return" + , "One" + , "Control" + , "Latin Small Letter O With Diaeresis" + , "Euro Sign" + , "Emoji: Grinning Face" + , "Hebrew Letter Dalet With Dagesh" + ] + +recordTextValues :: LBS.ByteString -> [Text] +recordTextValues lbs = case lbsToTokens lbs of + TkRecordOpen r -> go r + _ -> [] + where + go (TkPair _ (TkText s ts)) = s : go ts + go _ = [] + +------------------------------------------------------------------------------- +-- Numbers +------------------------------------------------------------------------------- + +-- Appendix B. Number Serialization Samples +numbers :: [(Word64, LBS.ByteString)] +numbers = + [ (0x0000000000000000, "0") -- Zero + , (0x8000000000000000, "0") -- Minus zero + , (0x0000000000000001, "5e-324") -- Min pos number + , (0x8000000000000001, "-5e-324") -- Min neg number + , (0x7fefffffffffffff, "1.7976931348623157e+308") -- Max pos number + , (0xffefffffffffffff, "-1.7976931348623157e+308") -- Max neg number + , (0x4340000000000000, "9007199254740992") -- Max pos int (1) + , (0xc340000000000000, "-9007199254740992") -- Max neg int (1) + , (0x4430000000000000, "295147905179352830000") -- ~2**68 (2) + , (0x44b52d02c7e14af5, "9.999999999999997e+22") + , (0x44b52d02c7e14af6, "1e+23") + , (0x44b52d02c7e14af7, "1.0000000000000001e+23") + , (0x444b1ae4d6e2ef4e, "999999999999999700000") + , (0x444b1ae4d6e2ef4f, "999999999999999900000") + , (0x444b1ae4d6e2ef50, "1e+21") + , (0x3eb0c6f7a0b5ed8c, "9.999999999999997e-7") + , (0x3eb0c6f7a0b5ed8d, "0.000001") + , (0x41b3de4355555553, "333333333.3333332") + , (0x41b3de4355555554, "333333333.33333325") + , (0x41b3de4355555555, "333333333.3333333") + , (0x41b3de4355555556, "333333333.3333334") + , (0x41b3de4355555557, "333333333.33333343") + , (0xbecbf647612f3696, "-0.0000033333333333333333") + , (0x43143ff3c1cb0959, "1424953923781206.2") -- Round to even (4) + ] + +numberCases :: TestTree +numberCases = testGroup "numbers" + [ testCase (LBS8.unpack lbs) $ do + encodeCanonical (doubleToScientific d) @?= lbs + | (w64, lbs) <- numbers + , let d = castWord64ToDouble w64 :: Double + ] diff --git a/tests/Regression/Issue1138.hs b/tests/Regression/Issue1138.hs new file mode 100644 --- /dev/null +++ b/tests/Regression/Issue1138.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Regression.Issue1138 (issue1138) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertFailure) + +import Data.Aeson + +assertDecodeFailure :: Either String Value -> IO () +assertDecodeFailure (Right v) = assertFailure $ "Unexpected success: " ++ show v +assertDecodeFailure (Left _) = return () + +issue1138 :: TestTree +issue1138 = testGroup "Issue #1138" $ map (testCase "-") + [ assertDecodeFailure $ eitherDecode "\"\t\"" + , assertDecodeFailure $ eitherDecode "\"\\\\\t\"" + + , assertDecodeFailure $ eitherDecodeStrict "\"\t\"" + , assertDecodeFailure $ eitherDecodeStrict "\"\\\\\t\"" + + , assertDecodeFailure $ eitherDecodeStrictText "\"\t\"" + , assertDecodeFailure $ eitherDecodeStrictText "\"\\\\\t\"" + ] diff --git a/tests/Regression/Issue351.hs b/tests/Regression/Issue351.hs new file mode 100644 --- /dev/null +++ b/tests/Regression/Issue351.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module Regression.Issue351 (issue351) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertEqual) +import Data.Maybe (fromMaybe) + +import qualified Data.ByteString.Lazy as L + +import Data.Aeson + +-- A regression test for: https://github.com/bos/aeson/issues/351 +overlappingRegression :: FromJSON a => L.ByteString -> [a] +overlappingRegression bs = fromMaybe [] $ decode bs + +issue351 :: TestTree +issue351 = testGroup "Issue #351" $ map (testCase "-") + [ assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]" + , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\"" + , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]" + ] diff --git a/tests/Regression/Issue571.hs b/tests/Regression/Issue571.hs new file mode 100644 --- /dev/null +++ b/tests/Regression/Issue571.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +module Regression.Issue571 (issue571) where + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import GHC.Generics (Generic) + +import Data.Aeson + +data F = F + { a :: Maybe Int + , b :: Maybe Int + , c :: () + } + deriving (Eq, Show, Generic) + +instance FromJSON F where + parseJSON = genericParseJSON defaultOptions { omitNothingFields = False } -- default + +data G = G + { e :: Maybe Int + , f :: Maybe Int + , g :: () + } + deriving (Eq, Show, Generic) + +instance FromJSON G where + parseJSON = genericParseJSON defaultOptions { omitNothingFields = False, allowOmittedFields = False } + + +issue571 :: TestTree +issue571 = testCase "issue571" $ do + -- the Maybe fields can be omitted. + let actualF = decode "{}" :: Maybe F + actualF @?= Just F { a = Nothing, b = Nothing, c = () } + + (decode "{}" :: Maybe G) @?= Nothing + (decode "{\"e\":1, \"f\":2}" :: Maybe G) @?= Nothing + (decode "{\"e\":1, \"g\":[]}" :: Maybe G) @?= Nothing + (decode "{\"f\":2, \"g\":[]}" :: Maybe G) @?= Nothing + (decode "{\"e\":1, \"f\":2, \"g\":[]}" :: Maybe G) @?= Just G { e = Just 1, f = Just 2, g = () } + (decode "{\"e\":1, \"f\":2, \"g\":true}" :: Maybe G) @?= Just G { e = Just 1, f = Just 2, g = () } diff --git a/tests/Regression/Issue687.hs b/tests/Regression/Issue687.hs new file mode 100644 --- /dev/null +++ b/tests/Regression/Issue687.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveGeneric, TypeApplications, OverloadedStrings, TemplateHaskell, DuplicateRecordFields #-} +module Regression.Issue687 where + +import GHC.Generics (Generic1) +import Data.Aeson +import Data.Aeson.Types (iparseEither) +import Data.Aeson.Encoding (encodingToLazyByteString) +import Data.Aeson.TH (deriveJSON1) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +data ExG a = ExG { required :: a, optional :: Maybe a } + deriving (Eq, Show, Generic1) + +data ExTH a = ExTH { required :: a, optional :: Maybe a } + deriving (Eq, Show, Generic1) + +instance ToJSON1 ExG where + liftToJSON = genericLiftToJSON defaultOptions { omitNothingFields = True } + liftToEncoding = genericLiftToEncoding defaultOptions { omitNothingFields = True } + +instance FromJSON1 ExG where + liftParseJSON = genericLiftParseJSON defaultOptions { omitNothingFields = True } + +$(deriveJSON1 defaultOptions { omitNothingFields = True } ''ExTH) + +issue687 :: TestTree +issue687 = testCase "issue687" $ do + example (ExG @Int 1 Nothing) $ object [ "required" .= (1 :: Int) ] + example (ExG @Int 1 (Just 2)) $ object [ "required" .= (1 :: Int), "optional" .= (2 :: Int) ] + + example (ExTH @Int 1 Nothing) $ object [ "required" .= (1 :: Int) ] + example (ExTH @Int 1 (Just 2)) $ object [ "required" .= (1 :: Int), "optional" .= (2 :: Int) ] + + where + example :: (ToJSON1 f, FromJSON1 f, Eq (f Int), Show (f Int)) => f Int -> Value -> IO () + example x val = do + -- encoding + toJSON1 x @?= val + decode (encodingToLazyByteString (toEncoding1 x)) @?= Just val + + -- decoding + iparseEither parseJSON1 val @?= Right x diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -9,10 +9,11 @@ import qualified Properties import qualified UnitTests import qualified JSONTestSuite +import RFC8785 main :: IO () main = do ioTests <- UnitTests.ioTests jsTests <- JSONTestSuite.tests - let allTests = DF.tests : Properties.tests : UnitTests.tests : jsTests : ioTests + let allTests = DF.tests : rfc8785Tests : Properties.tests : UnitTests.tests : jsTests : ioTests defaultMain (testGroup "tests" allTests) diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -13,7 +13,6 @@ import Prelude.Compat import Math.NumberTheory.Logarithms (intLog2) -import Control.Applicative ((<$>)) import Data.Data import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) @@ -21,13 +20,15 @@ #if !MIN_VERSION_base(4,16,0) import Data.Semigroup (Option) #endif -import Data.Text +import Data.Text (Text) import Data.Time (Day (..), fromGregorian) import GHC.Generics import Test.QuickCheck (Arbitrary (..), Property, counterexample, scale) +import Test.QuickCheck.Gen (chooseUpTo) import qualified Data.Map as Map import Data.Aeson import Data.Aeson.Types +import Data.Word (Word64) type I = Identity type Compose3 f g h = Compose (Compose f g) h @@ -40,32 +41,32 @@ -- This definition causes an infinite loop in genericTo and genericFrom! -- , fooMap :: Map.Map String Foo , fooMap :: Map.Map String (Text,Int) - } deriving (Show, Typeable, Data) + } deriving (Show, Data) data UFoo = UFoo { _UFooInt :: Int , uFooInt :: Int - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Eq, Data) data NoConstructors data OneConstructor = OneConstructor - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Product2 a b = Product2 a b - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Product6 a b c d e f = Product6 a b c d e f - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) class ApproxEq a where (=~) :: a -> a -> Bool newtype Approx a = Approx { fromApprox :: a } - deriving (Show, Data, Typeable, ApproxEq, Num) + deriving (Show, Data, ApproxEq, Num) instance (ApproxEq a) => Eq (Approx a) where Approx a == Approx b = a =~ b @@ -82,18 +83,6 @@ | List [a] deriving (Eq, Show) --- | This type requires IncoherentInstances for the instances of the type --- classes Data.Aeson.TH.LookupField and Data.Aeson.Types.FromJSON.FromRecord. --- --- The minimum known requirements for this type are: --- * Record type with at least two fields --- * One field type is either a type parameter or a type/data family --- * Another field type is a @Maybe@ of the above field type -data IncoherentInstancesNeeded a = IncoherentInstancesNeeded - { incoherentInstancesNeededMaybeNot :: a - , incoherentInstancesNeededMaybeYes :: Maybe a - } deriving Generic - -- Used for testing UntaggedValue SumEncoding data EitherTextInt = LeftBool Bool @@ -104,7 +93,6 @@ data GADT a where GADT :: { gadt :: String } -> GADT String - deriving Typeable deriving instance Data (GADT String) deriving instance Eq (GADT a) @@ -177,3 +165,13 @@ instance (FromJSONKey a) => FromJSONKey (LogScaled a) where fromJSONKey = fmap LogScaled fromJSONKey fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a]) + +newtype UniformWord64 = U64 Word64 + deriving (Eq, Ord) + +instance Show UniformWord64 where + showsPrec d (U64 w) = showsPrec d w + +instance Arbitrary UniformWord64 where + arbitrary = U64 <$> chooseUpTo maxBound + shrink (U64 w) = map U64 (shrink w) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -7,7 +7,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecursiveDo #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE DerivingVia #-} @@ -17,9 +16,7 @@ -- For Data.Aeson.Types.camelTo {-# OPTIONS_GHC -fno-warn-deprecations #-} -#if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -#endif module UnitTests ( @@ -30,54 +27,54 @@ import Prelude.Compat -import Control.Applicative (Const) import Control.Monad (forM, forM_, when) -import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON) +import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON) import Data.Aeson.Types (JSONPathElement(..), formatError) import Data.Aeson.QQ.Simple (aesonQQ) import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1) import Data.Aeson.Text (encodeToTextBuilder) -import Data.Aeson.Parser - ( json, jsonLast, jsonAccum, jsonNoDup - , json', jsonLast', jsonAccum', jsonNoDup') import Data.Aeson.Types ( Options(..), Result(Success, Error), ToJSON(..) - , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2 - , explicitParseField, liftParseJSON, listParser - , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse, parseMaybe) -import qualified Data.Aeson.Types -import qualified Data.Aeson.KeyMap as KM -import Data.Attoparsec.ByteString (Parser, parseOnly) + , Value(..), camelTo, camelTo2 + , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse) import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory) -import Data.Hashable (hash) +import Data.Fixed (Nano) import Data.HashMap.Strict (HashMap) +import Data.Kind (Type) import Data.List (isSuffixOf) -import Data.Maybe (fromMaybe) import Data.Scientific (Scientific, scientific) -import Data.Tagged (Tagged(..)) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale) import GHC.Generics (Generic) +#if __GLASGOW_HASKELL__ >= 806 import GHC.Generics.Generically (Generically (..)) +#endif import Instances () import Numeric.Natural (Natural) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, testCase) import Text.Printf (printf) -import UnitTests.NullaryConstructors (nullaryConstructors) -import qualified Data.ByteString as S import qualified Data.ByteString.Base16.Lazy as LBase16 import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.Vector as Vector import qualified ErrorMessages import qualified SerializationFormatSpec -import qualified Data.Map as Map -- Lazy! + +import Regression.Issue351 +import Regression.Issue571 +import Regression.Issue687 import Regression.Issue967 +import Regression.Issue1138 +import UnitTests.OmitNothingFieldsNote +import UnitTests.FromJSONKey +import UnitTests.Hashable +import UnitTests.KeyMapInsertWith +import UnitTests.MonadFix +import UnitTests.NoThunks +import UnitTests.NullaryConstructors (nullaryConstructors) +import UnitTests.OptionalFields (optionalFields) +import UnitTests.UTCTime roundTripCamel :: String -> Assertion roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name) @@ -86,11 +83,13 @@ roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name) camelFrom :: Char -> String -> String -camelFrom c s = let (p:ps) = split c s - in concat $ p : map capitalize ps +camelFrom c s = case split c s of + p:ps -> concat $ p : map capitalize ps + _ -> s -- shouldn't happen? where split c' s' = map L.unpack $ L.split c' $ L.pack s' - capitalize t = toUpper (head t) : tail t + capitalize [] = [] + capitalize (x:xs) = toUpper x : xs data Wibble = Wibble { @@ -122,90 +121,6 @@ | otherwise = 4030 arch32bit = (maxBound :: Int) == 2147483647 --- Test decoding various UTC time formats --- --- Note: the incomplete pattern matches for UTCTimes are completely --- intentional. The test expects these parses to succeed. If the --- pattern matches fails, there's a bug in either the test or in aeson --- and needs to be investigated. -utcTimeGood :: Assertion -utcTimeGood = do - let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text - let ts2 = "2015-01-01T12:13:00Z" :: LT.Text - -- 'T' between date and time is not required, can be space - let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text - let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text - let (Just (t1 :: UTCTime)) = parseWithAeson ts1 - let (Just (t2 :: UTCTime)) = parseWithAeson ts2 - let (Just (t3 :: UTCTime)) = parseWithAeson ts3 - let (Just (t4 :: UTCTime)) = parseWithAeson ts4 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2 - assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3 - assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4 - -- Time zones. Both +HHMM and +HH:MM are allowed for timezone - -- offset, and MM may be omitted. - let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text - let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text - let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text - let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text - let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text - let (Just (t5 :: UTCTime)) = parseWithAeson ts5 - let (Just (t6 :: UTCTime)) = parseWithAeson ts6 - let (Just (t7 :: UTCTime)) = parseWithAeson ts7 - let (Just (t8 :: UTCTime)) = parseWithAeson ts8 - let (Just (t9 :: UTCTime)) = parseWithAeson ts9 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7 - -- ts8 wraps around to the next day in UTC - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9 - - -- Seconds in Time can be omitted - let ts10 = "2015-01-03T12:13Z" :: LT.Text - let ts11 = "2015-01-03 12:13Z" :: LT.Text - let ts12 = "2015-01-01T12:30-02" :: LT.Text - let (Just (t10 :: UTCTime)) = parseWithAeson ts10 - let (Just (t11 :: UTCTime)) = parseWithAeson ts11 - let (Just (t12 :: UTCTime)) = parseWithAeson ts12 - assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10 - assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12 - - -- leap seconds are included correctly - let ts13 = "2015-08-23T23:59:60.128+00" :: LT.Text - let (Just (t13 :: UTCTime)) = parseWithAeson ts13 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.128Z") t13 - let ts14 = "2015-08-23T23:59:60.999999999999+00" :: LT.Text - let (Just (t14 :: UTCTime)) = parseWithAeson ts14 - assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.999999999999Z") t14 - - where - parseWithRead :: String -> LT.Text -> UTCTime - parseWithRead f s = - fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s - parseWithAeson :: LT.Text -> Maybe UTCTime - parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] - --- Test that a few non-timezone qualified timestamp formats get --- rejected if decoding to UTCTime. -utcTimeBad :: Assertion -utcTimeBad = do - verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required) - verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required) - verifyFailParse "2000-01-01" -- date only not OK - verifyFailParse "2000-01-01Z" -- date only not OK - verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given - verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given - verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits - verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds - verifyFailParse "2015-01-03 23:59:61Z" -- exceeds allowed seconds per day - where - verifyFailParse (s :: LT.Text) = - let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in - assertEqual "verify failure" Nothing dec - -- Non identifier keys should be escaped & enclosed in brackets formatErrorExample :: Assertion formatErrorExample = @@ -256,18 +171,6 @@ ex3 = "{\"value\": null }" ------------------------------------------------------------------------------ --- Check that the hashes of two equal Value are the same ------------------------------------------------------------------------------- - -hashableLaws :: [Assertion] -hashableLaws = [ - assertEqual "Hashable Object" (hash a) (hash b) - ] - where - a = object ["223" .= False, "807882556" .= True] - b = object ["807882556" .= True, "223" .= False] - ------------------------------------------------------------------------------- -- Check that an alternative way to construct objects works ------------------------------------------------------------------------------ @@ -279,71 +182,10 @@ recommended = object ["foo" .= True, "bar" .= (-1 :: Int)] notRecommended = Object (mconcat ["foo" .= True, "bar" .= (-1 :: Int)]) -------------------------------------------------------------------------------- --- ToJSONKey -------------------------------------------------------------------------------- - -newtype MyText = MyText Text - deriving (FromJSONKey) - -newtype MyText' = MyText' Text - -instance FromJSONKey MyText' where - fromJSONKey = fmap MyText' fromJSONKey - fromJSONKeyList = error "not used" - -fromJSONKeyAssertions :: [Assertion] -fromJSONKeyAssertions = - [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text) - , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text)) - , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText) - -#if __GLASGOW_HASKELL__ >= 710 - , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') - , assertIsCoerce "Const Text" (fromJSONKey :: FromJSONKeyFunction (Const Text ())) -#endif - ] - where - assertIsCoerce :: String -> FromJSONKeyFunction a -> Assertion - assertIsCoerce _ FromJSONKeyCoerce = pure () - assertIsCoerce n _ = assertFailure n - -#if __GLASGOW_HASKELL__ >= 710 - assertIsCoerce' :: String -> FromJSONKeyFunction a -> Assertion - assertIsCoerce' _ FromJSONKeyCoerce = pure () - assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ()) - --- | Pick the first when RULES are enabled, e.g. optimisations are on -pickWithRules - :: a -- ^ Pick this when RULES are on - -> a -- ^ use this otherwise - -> a -pickWithRules _ = id -{-# NOINLINE pickWithRules #-} -{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-} -#endif - ------------------------------------------------------------------------------ --- Regressions ------------------------------------------------------------------------------- - --- A regression test for: https://github.com/bos/aeson/issues/351 -overlappingRegression :: FromJSON a => L.ByteString -> [a] -overlappingRegression bs = fromMaybe [] $ decode bs - -issue351 :: [Assertion] -issue351 = [ - assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]" - , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\"" - , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]" - ] - ------------------------------------------------------------------------------- -- Comparison between bytestring and text encoders ------------------------------------------------------------------------------ - - encoderComparisonTests :: IO TestTree encoderComparisonTests = do encoderTests <- forM testFiles $ \file0 -> do @@ -425,7 +267,7 @@ pr455 :: Assertion pr455 = assertEqual "FooCons FooNil" - (toJSON foo) (liftToJSON undefined undefined foo) + (toJSON foo) (liftToJSON undefined undefined undefined foo) where foo :: Foo Int foo = FooCons FooNil @@ -439,6 +281,7 @@ ++ ", constructorTagModifier =~ \"ExampleConstructor\"" ++ ", allNullaryToStringTag = True" ++ ", omitNothingFields = False" + ++ ", allowOmittedFields = True" ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" ++ ", unwrapUnaryRecords = False" ++ ", tagSingleConstructors = False" @@ -568,6 +411,7 @@ testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree] testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts)) +{- testParser :: (Eq a, Show a) => String -> Parser a -> S.ByteString -> Either String a -> TestTree testParser name json_ s expected = @@ -601,6 +445,7 @@ "{\"k\":true,\"k\":false}" $ Left "Failed reading: found duplicate key: \"k\"" ] +-} ratioDenominator0 :: Assertion ratioDenominator0 = @@ -615,17 +460,22 @@ (eitherDecode "1.37" :: Either String Rational) bigRationalDecoding :: Assertion -bigRationalDecoding = - assertEqual "Decoding an Integer with a large exponent should fail" - (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024") +bigRationalDecoding = do + assertEqual "Decoding a Rational with a large exponent should fail" + (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024") ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000") - -smallRationalDecoding :: Assertion -smallRationalDecoding = - assertEqual "Decoding an Integer with a large exponent should fail" - (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024") + assertEqual "Decoding a Rational with a small exponent should fail" + (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be less than -1024") ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000") +bigFixedDecoding :: Assertion +bigFixedDecoding = do + assertEqual "Decoding a Fixed with a large exponent should fail" + (Left "Error in $: parsing Fixed failed, found a number with exponent 9999, but it must not be greater than 1024") + ((eitherDecode :: L.ByteString -> Either String Nano) "1e9999") + assertEqual "Decoding a Fixed with a small exponent should fail" + (Left "Error in $: parsing Fixed failed, found a number with exponent -9999, but it must not be less than -1024") + ((eitherDecode :: L.ByteString -> Either String Nano) "1e-9999") bigScientificExponent :: Assertion bigScientificExponent = @@ -658,112 +508,12 @@ ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }") -- A regression test for: https://github.com/bos/aeson/issues/757 -type family Fam757 :: * -> * +type family Fam757 :: Type -> Type type instance Fam757 = Maybe newtype Newtype757 a = MkNewtype757 (Fam757 a) deriveToJSON1 defaultOptions ''Newtype757 ------------------------------------------------------------------------------- --- MonadFix -------------------------------------------------------------------------------- - -monadFixDecoding1 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion -monadFixDecoding1 p = do - fmap (take 10) (parseMaybe p value) @?= Just "xyzxyzxyzx" - where - value = object - [ "foo" .= ('x', "bar" :: String) - , "bar" .= ('y', "quu" :: String) - , "quu" .= ('z', "foo" :: String) - ] - -monadFixDecoding2 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion -monadFixDecoding2 p = do - fmap (take 10) (parseMaybe p value) @?= Nothing - where - value = object - [ "foo" .= ('x', "bar" :: String) - , "bar" .= ('y', "???" :: String) - , "quu" .= ('z', "foo" :: String) - ] - -monadFixDecoding3 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion -monadFixDecoding3 p = - fmap (take 10) (parseMaybe p value) @?= Nothing - where - value = object - [ "foo" .= ('x', "bar" :: String) - , "bar" .= Null - , "quu" .= ('z', "foo" :: String) - ] - -monadFixDecoding4 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion -monadFixDecoding4 p = - fmap (take 10) (parseMaybe p value) @?= Nothing - where - value = object - [ "els" .= ('x', "bar" :: String) - , "bar" .= Null - , "quu" .= ('z', "foo" :: String) - ] - --- Parser with explicit references -monadFixParserA :: Value -> Data.Aeson.Types.Parser [Char] -monadFixParserA = withObject "Rec" $ \obj -> mdo - let p'' :: Value -> Data.Aeson.Types.Parser String - p'' "foo" = return foo - p'' "bar" = return bar - p'' "quu" = return quu - p'' _ = fail "Invalid reference" - - let p' :: Value -> Data.Aeson.Types.Parser [Char] - p' v = do - (c, cs) <- liftParseJSON p'' (listParser p'') v - return (c : cs) - - foo <- explicitParseField p' obj "foo" - bar <- explicitParseField p' obj "bar" - quu <- explicitParseField p' obj "quu" - return foo - --- Parser with arbitrary references! -monadFixParserB :: Value -> Data.Aeson.Types.Parser [Char] -monadFixParserB = withObject "Rec" $ \obj -> mdo - let p'' :: Value -> Data.Aeson.Types.Parser String - p'' key' = do - key <- parseJSON key' - -- this is ugly: we look whether key is in original obj - -- but then query from refs. - -- - -- This way we are lazier. Map.traverse isn't lazy enough. - case KM.lookup key obj of - Just _ -> return (refs Map.! key) - Nothing -> fail "Invalid reference" - - let p' :: Value -> Data.Aeson.Types.Parser [Char] - p' v = do - (c, cs) <- liftParseJSON p'' (listParser p'') v - return (c : cs) - - refs <- traverse p' (KM.toMap obj) - case Map.lookup "foo" refs of - Nothing -> fail "No foo node" - Just root -> return root - -monadFixTests :: TestTree -monadFixTests = testGroup "MonadFix" - [ testCase "Example1a" $ monadFixDecoding1 monadFixParserA - , testCase "Example2a" $ monadFixDecoding2 monadFixParserA - , testCase "Example3a" $ monadFixDecoding3 monadFixParserA - , testCase "Example4a" $ monadFixDecoding4 monadFixParserA - - , testCase "Example1b" $ monadFixDecoding1 monadFixParserB - , testCase "Example2b" $ monadFixDecoding2 monadFixParserB - , testCase "Example3b" $ monadFixDecoding3 monadFixParserB - , testCase "Example4b" $ monadFixDecoding4 monadFixParserB - ] - -------------------------------------------------------------------------------- -- Tests trees ------------------------------------------------------------------------------- @@ -791,19 +541,16 @@ , testGroup "encoding" [ testCase "goodProducer" goodProducer ] - , testGroup "utctime" [ - testCase "good" utcTimeGood - , testCase "bad" utcTimeBad - ] + , utcTimeTests , testGroup "formatError" [ testCase "example 1" formatErrorExample ] , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark - , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws + , hashableLaws , testGroup "Object construction" $ fmap (testCase "-") objectConstruction - , testGroup "Issue #351" $ fmap (testCase "-") issue351 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors - , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions + , fromJSONKeyTests + , optionalFields , testCase "PR #455" pr455 , testCase "Unescape string (PR #477)" unescapeString , testCase "Show Options" showOptions @@ -811,11 +558,11 @@ , testCase "withEmbeddedJSON" withEmbeddedJSONTest , testCase "SingleFieldCon" singleFieldCon , testGroup "UnknownFields" unknownFields - , testGroup "Ordering of object keys" keyOrdering + -- , testGroup "Ordering of object keys" keyOrdering , testCase "Ratio with denominator 0" ratioDenominator0 , testCase "Rational parses number" rationalNumber , testCase "Big rational" bigRationalDecoding - , testCase "Small rational" smallRationalDecoding + , testCase "Big fixed" bigFixedDecoding , testCase "Big scientific exponent" bigScientificExponent , testCase "Big integer decoding" bigIntegerDecoding , testCase "Big natural decoding" bigNaturalDecoding @@ -825,10 +572,12 @@ assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |] ] , monadFixTests + , issue351 + , issue571 + , issue687 , issue967 - , testCase "KeyMap.insertWith" $ do - KM.insertWith (-) "a" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",1 :: Int)] - KM.insertWith (flip (-)) "a" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",-1 :: Int)] - KM.insertWith (-) "b" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",1),("b",2 :: Int)] - KM.insertWith (-) "b" 2 KM.empty @?= KM.fromList [("b",2 :: Int)] + , issue1138 + , keyMapInsertWithTests + , omitNothingFieldsNoteTests + , noThunksTests ] diff --git a/tests/UnitTests/FromJSONKey.hs b/tests/UnitTests/FromJSONKey.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/FromJSONKey.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module UnitTests.FromJSONKey (fromJSONKeyTests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, Assertion, assertFailure) +import Data.Text (Text) +import Data.Tagged (Tagged) +import Control.Applicative (Const) + +import Data.Aeson + +newtype MyText = MyText Text + deriving (FromJSONKey) + +newtype MyText' = MyText' Text + +instance FromJSONKey MyText' where + fromJSONKey = fmap MyText' fromJSONKey + fromJSONKeyList = error "not used" + +fromJSONKeyTests :: TestTree +fromJSONKeyTests = testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions + +fromJSONKeyAssertions :: [Assertion] +fromJSONKeyAssertions = + [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text) + , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text)) + , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText) + + , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') + , assertIsCoerce "Const Text" (fromJSONKey :: FromJSONKeyFunction (Const Text ())) + ] + where + assertIsCoerce :: String -> FromJSONKeyFunction a -> Assertion + assertIsCoerce _ FromJSONKeyCoerce = pure () + assertIsCoerce n _ = assertFailure n + + assertIsCoerce' :: String -> FromJSONKeyFunction a -> Assertion + assertIsCoerce' _ FromJSONKeyCoerce = pure () + assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ()) + +-- | Pick the first when RULES are enabled, e.g. optimisations are on +pickWithRules + :: a -- ^ Pick this when RULES are on + -> a -- ^ use this otherwise + -> a +pickWithRules _ = id +{-# NOINLINE pickWithRules #-} +{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-} diff --git a/tests/UnitTests/Hashable.hs b/tests/UnitTests/Hashable.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Hashable.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module UnitTests.Hashable (hashableLaws) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertEqual) +import Data.Hashable (hash) + +import Data.Aeson + +------------------------------------------------------------------------------ +-- Check that the hashes of two equal Value are the same +------------------------------------------------------------------------------ + +hashableLaws :: TestTree +hashableLaws = testGroup "Hashable laws" $ fmap (testCase "-") + [ assertEqual "Hashable Object" (hash a) (hash b) + ] + where + a = object ["223" .= False, "807882556" .= True] + b = object ["807882556" .= True, "223" .= False] diff --git a/tests/UnitTests/KeyMapInsertWith.hs b/tests/UnitTests/KeyMapInsertWith.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/KeyMapInsertWith.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +module UnitTests.KeyMapInsertWith (keyMapInsertWithTests) where + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +import qualified Data.Aeson.KeyMap as KM + +keyMapInsertWithTests :: TestTree +keyMapInsertWithTests = testCase "KeyMap.insertWith" $ do + KM.insertWith (-) "a" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",1 :: Int)] + KM.insertWith (flip (-)) "a" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",-1 :: Int)] + KM.insertWith (-) "b" 2 (KM.fromList [("a", 1)]) @?= KM.fromList [("a",1),("b",2 :: Int)] + KM.insertWith (-) "b" 2 KM.empty @?= KM.fromList [("b",2 :: Int)] diff --git a/tests/UnitTests/MonadFix.hs b/tests/UnitTests/MonadFix.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/MonadFix.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +module UnitTests.MonadFix (monadFixTests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, Assertion, (@?=)) + +import qualified Data.Map as Map -- Lazy + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Aeson.KeyMap as KM + +------------------------------------------------------------------------------- +-- MonadFix +------------------------------------------------------------------------------- + +monadFixDecoding1 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion +monadFixDecoding1 p = do + fmap (take 10) (parseMaybe p value) @?= Just "xyzxyzxyzx" + where + value = object + [ "foo" .= ('x', "bar" :: String) + , "bar" .= ('y', "quu" :: String) + , "quu" .= ('z', "foo" :: String) + ] + +monadFixDecoding2 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion +monadFixDecoding2 p = do + fmap (take 10) (parseMaybe p value) @?= Nothing + where + value = object + [ "foo" .= ('x', "bar" :: String) + , "bar" .= ('y', "???" :: String) + , "quu" .= ('z', "foo" :: String) + ] + +monadFixDecoding3 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion +monadFixDecoding3 p = + fmap (take 10) (parseMaybe p value) @?= Nothing + where + value = object + [ "foo" .= ('x', "bar" :: String) + , "bar" .= Null + , "quu" .= ('z', "foo" :: String) + ] + +monadFixDecoding4 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion +monadFixDecoding4 p = + fmap (take 10) (parseMaybe p value) @?= Nothing + where + value = object + [ "els" .= ('x', "bar" :: String) + , "bar" .= Null + , "quu" .= ('z', "foo" :: String) + ] + +-- Parser with explicit references +monadFixParserA :: Value -> Data.Aeson.Types.Parser [Char] +monadFixParserA = withObject "Rec" $ \obj -> mdo + let p'' :: Value -> Data.Aeson.Types.Parser String + p'' "foo" = return foo + p'' "bar" = return bar + p'' "quu" = return quu + p'' _ = fail "Invalid reference" + + let p' :: Value -> Data.Aeson.Types.Parser [Char] + p' v = do + (c, cs) <- liftParseJSON Nothing p'' (listParser p'') v + return (c : cs) + + foo <- explicitParseField p' obj "foo" + bar <- explicitParseField p' obj "bar" + quu <- explicitParseField p' obj "quu" + return foo + +-- Parser with arbitrary references! +monadFixParserB :: Value -> Data.Aeson.Types.Parser [Char] +monadFixParserB = withObject "Rec" $ \obj -> mdo + let p'' :: Value -> Data.Aeson.Types.Parser String + p'' key' = do + key <- parseJSON key' + -- this is ugly: we look whether key is in original obj + -- but then query from refs. + -- + -- This way we are lazier. Map.traverse isn't lazy enough. + case KM.lookup key obj of + Just _ -> return (refs Map.! key) + Nothing -> fail "Invalid reference" + + let p' :: Value -> Data.Aeson.Types.Parser [Char] + p' v = do + (c, cs) <- liftParseJSON Nothing p'' (listParser p'') v + return (c : cs) + + refs <- traverse p' (KM.toMap obj) + case Map.lookup "foo" refs of + Nothing -> fail "No foo node" + Just root -> return root + +monadFixTests :: TestTree +monadFixTests = testGroup "MonadFix" + [ testCase "Example1a" $ monadFixDecoding1 monadFixParserA + , testCase "Example2a" $ monadFixDecoding2 monadFixParserA + , testCase "Example3a" $ monadFixDecoding3 monadFixParserA + , testCase "Example4a" $ monadFixDecoding4 monadFixParserA + + , testCase "Example1b" $ monadFixDecoding1 monadFixParserB + , testCase "Example2b" $ monadFixDecoding2 monadFixParserB + , testCase "Example3b" $ monadFixDecoding3 monadFixParserB + , testCase "Example4b" $ monadFixDecoding4 monadFixParserB + ] diff --git a/tests/UnitTests/NoThunks.hs b/tests/UnitTests/NoThunks.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/NoThunks.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module UnitTests.NoThunks where + +import Test.Tasty (TestTree, testGroup) + +#if __GLASGOW_HASKELL__ >=902 && __GLASGOW_HASKELL__ <907 + +import Data.Maybe (isNothing) +import NoThunks.Class (NoThunks (..), allNoThunks, noThunksInKeysAndValues) +import Test.QuickCheck (ioProperty) +import Test.Tasty.HUnit (assertFailure, testCase) +import Test.Tasty.QuickCheck (testProperty) + +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Scientific as Sci + +import Data.Aeson + +noThunksTests :: TestTree +noThunksTests = testGroup "nothunks" + [ testNoThunks "example1" "null" + , testNoThunks "example2" "[ 1, 2, 3, true ]" + , testNoThunks "example3" "{ \"1\": 1, \"2\": 2 }" + , testProperty "property" $ \input -> ioProperty $ do + let lbs = encode (input :: Value) + !value <- either fail return $ eitherDecode lbs + isNothing <$> noThunks [] (value :: Value) + ] + where + testNoThunks name bs = testCase name $ do + !value <- either fail return $ eitherDecode bs + x <- noThunks [] (value :: Value) + case x of + Nothing -> return () + Just ti -> assertFailure $ show ti + +instance NoThunks Value + +instance NoThunks v => NoThunks (KM.KeyMap v) where + wNoThunks ctx m = noThunksInKeysAndValues ctx (KM.toList m) + showTypeOf _ = "KeyMap" + +instance NoThunks K.Key where + wNoThunks _ _ = return Nothing + showTypeOf _ = "Key" + +instance NoThunks Sci.Scientific where + wNoThunks ctx s = do + let !c = Sci.coefficient s + let !e = Sci.base10Exponent s + allNoThunks [ wNoThunks ctx c, wNoThunks ctx e ] + showTypeOf _ = "Scientific" + +#else + +-- for other GHCs the test group is empty +noThunksTests :: TestTree +noThunksTests = testGroup "nothunks" [] + +#endif diff --git a/tests/UnitTests/NullaryConstructors.hs b/tests/UnitTests/NullaryConstructors.hs --- a/tests/UnitTests/NullaryConstructors.hs +++ b/tests/UnitTests/NullaryConstructors.hs @@ -11,8 +11,7 @@ import Prelude.Compat import Data.Aeson (decode, eitherDecode, fromEncoding, Value) -import Data.Aeson.Internal (IResult (..), iparse) -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, IResult (..), iparse) import Data.ByteString.Builder (toLazyByteString) import Data.Foldable (for_) import Data.Maybe (fromJust) diff --git a/tests/UnitTests/OmitNothingFieldsNote.hs b/tests/UnitTests/OmitNothingFieldsNote.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OmitNothingFieldsNote.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +module UnitTests.OmitNothingFieldsNote (omitNothingFieldsNoteTests) where + +-- prior aeson-2.2 the 'omitNothingFields' had the following note, +-- which is no longer true as these tests illustrate. + +-- Setting 'omitNothingFields' to 'True' only affects fields which are of +-- type 'Maybe' /uniformly/ in the 'ToJSON' instance. +-- In particular, if the type of a field is declared as a type variable, it +-- will not be omitted from the JSON object, unless the field is +-- specialized upfront in the instance. +-- +-- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance. +-- +-- ==== __Example__ +-- +-- The generic instance for the following type @Fruit@ depends on whether +-- the instance head is @Fruit a@ or @Fruit (Maybe a)@. +-- +-- @ +-- data Fruit a = Fruit +-- { apples :: a -- A field whose type is a type variable. +-- , oranges :: 'Maybe' Int +-- } deriving 'Generic' +-- +-- -- apples required, oranges optional +-- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)). +-- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) +-- +-- -- apples optional, oranges optional +-- -- In this instance, the field apples is uniformly of type ('Maybe' a). +-- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) +-- +-- options :: 'Options' +-- options = 'defaultOptions' { 'omitNothingFields' = 'True' } +-- +-- -- apples always present in the output, oranges is omitted if 'Nothing' +-- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where +-- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options +-- +-- -- both apples and oranges are omitted if 'Nothing' +-- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where +-- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) +import GHC.Generics (Generic) +import Data.Aeson + +omitNothingFieldsNoteTests :: TestTree +omitNothingFieldsNoteTests = testCase "omitNothingFields Note" $ do + -- both fields are omitted, not only oranges! + encode (Fruit (Nothing :: Maybe Int) Nothing) @?= "{}" + +data Fruit a = Fruit + { apples :: a -- A field whose type is a type variable. + , oranges :: Maybe Int + } deriving Generic + +instance ToJSON a => ToJSON (Fruit a) where + toJSON = genericToJSON defaultOptions { omitNothingFields = True } + toEncoding = genericToEncoding defaultOptions { omitNothingFields = True } diff --git a/tests/UnitTests/OptionalFields.hs b/tests/UnitTests/OptionalFields.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OptionalFields.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module UnitTests.OptionalFields (optionalFields) where + +import GHC.Generics (Generic) +import Data.Maybe (isNothing) +import UnitTests.OptionalFields.Common +import UnitTests.OptionalFields.Generics (omitGenerics) +import UnitTests.OptionalFields.TH (omitTH) +import UnitTests.OptionalFields.Manual (omitManual) + +optionalFields :: TestTree +optionalFields = testGroup "optional fields" + [ omitGenerics + , omitTH + , omitManual + , proofOfConcept + ] + +-- c.f. https://github.com/haskell/aeson/pull/839#issuecomment-782453060 +data P = P + { x :: Nullable Int -- Field is required, but can be null. + , y :: Undefineable Int -- Field is optional, but cannot be null. + , z :: NullOrUndefineable Int -- Field is optional, and can be null. + } + deriving (Eq, Show, Generic) + +instance ToJSON P where + toJSON = genericToJSON opts + toEncoding = genericToEncoding opts + +instance FromJSON P where + parseJSON = genericParseJSON opts + +newtype Nullable a = Nullable (Maybe a) + deriving (Eq, Show, Generic) + +instance ToJSON a => ToJSON (Nullable a) where + toJSON = genericToJSON opts + toEncoding = genericToEncoding opts + +instance FromJSON a => FromJSON (Nullable a) where + parseJSON = genericParseJSON opts + +newtype Undefineable a = Undefineable (Maybe a) + deriving (Eq, Show, Generic) + +instance ToJSON a => ToJSON (Undefineable a) where + toJSON = genericToJSON opts + toEncoding = genericToEncoding opts + omitField (Undefineable a) = isNothing a + +instance FromJSON a => FromJSON (Undefineable a) where + parseJSON Null = fail "Undefineable.parseJSON: expected non-null value" + parseJSON v = genericParseJSON opts v + omittedField = Just (Undefineable Nothing) + +newtype NullOrUndefineable a = NullOrUndefineable (Maybe a) + deriving (Eq, Show, Generic) + +instance ToJSON a => ToJSON (NullOrUndefineable a) where + toJSON = genericToJSON opts + toEncoding = genericToEncoding opts + omitField (NullOrUndefineable a) = isNothing a + +instance FromJSON a => FromJSON (NullOrUndefineable a) where + parseJSON = genericParseJSON opts + omittedField = Just (NullOrUndefineable Nothing) + +opts :: Options +opts = defaultOptions { omitNothingFields = True } + +fullP :: P +fullP = P (Nullable $ Just 0) (Undefineable $ Just 0) (NullOrUndefineable $ Just 0) + +zero :: Key -> (Key, Value) +zero k = k .= (0 :: Int) + +proofOfConcept :: TestTree +proofOfConcept = testGroup "Type-directed optional fields Proof of Concept" + [ testGroup "toJSON" + [ testCase "x is not omitted when Nothing" $ + let subject = fullP {x = Nullable Nothing} + expected = object ["x" .= Null, zero "y", zero "z"] + in toJSON subject @?= expected + + , testCase "y is omitted when Nothing" $ + let subject = fullP {y = Undefineable Nothing} + expected = object [zero "x", zero "z"] + in toJSON subject @?= expected + + , testCase "z is omitted when Nothing" $ + let subject = fullP {z = NullOrUndefineable Nothing} + expected = object [zero "x", zero "y"] + in toJSON subject @?= expected + ] + + , testGroup "parseJSON" + [ testCase "x can be null" $ + let subject = object ["x" .= Null, zero "y", zero "z"] + expected = Just fullP {x = Nullable Nothing} + in decode (encode subject) @?= expected + + , testCase "x cannot be omitted" $ + let subject = object [zero "y", zero "z"] + expected = Nothing :: Maybe P + in decode (encode subject) @?= expected + + , testCase "y can be omitted" $ + let subject = object [zero "x", zero "z"] + expected = Just fullP {y = Undefineable Nothing} + in decode (encode subject) @?= expected + + , testCase "y cannot be null" $ + let subject = object [zero "x", "y" .= Null, zero "z"] + expected = Nothing :: Maybe P + in decode (encode subject) @?= expected + + , testCase "z can be null" $ + let subject = object [zero "x", zero "y", "z" .= Null] + expected = Just fullP {z = NullOrUndefineable Nothing} + in decode (encode subject) @?= expected + + , testCase "z can be omitted" $ + let subject = object [zero "x", zero "y"] + expected = Just fullP {z = NullOrUndefineable Nothing} + in decode (encode subject) @?= expected + ] + ] diff --git a/tests/UnitTests/OptionalFields/Common.hs b/tests/UnitTests/OptionalFields/Common.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OptionalFields/Common.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module UnitTests.OptionalFields.Common + ( module UnitTests.OptionalFields.Common + , module Data.Aeson + , module Data.Aeson.Types + , module Data.Aeson.TH + , module Test.Tasty + , module Test.Tasty.HUnit + , module Data.Proxy + ) where + +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.TH +import Data.Maybe (isNothing) +import GHC.Generics (Generic, Generic1) +import Data.Proxy +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.Text as T + +------------------------------------------------------------------------------- +-- Field types +------------------------------------------------------------------------------- + +newtype NullableNonEmptyString = NullableNonEmptyString (Maybe String) + deriving (Eq, Show) + +defaultNullableNonEmptyString :: NullableNonEmptyString +defaultNullableNonEmptyString = NullableNonEmptyString Nothing + +instance ToJSON NullableNonEmptyString where + toJSON (NullableNonEmptyString x) = toJSON x + toEncoding (NullableNonEmptyString x) = toEncoding x + omitField (NullableNonEmptyString x) = isNothing x + +instance FromJSON NullableNonEmptyString where + parseJSON Null = pure defaultNullableNonEmptyString + parseJSON (String x) = pure (nne $ T.unpack x) + parseJSON _ = fail "NullableNonEmptyString.parseJSON: expected String or Null" + + omittedField = Just defaultNullableNonEmptyString + + + +nne :: String -> NullableNonEmptyString +nne str = case filter (/= ' ') str of + "" -> NullableNonEmptyString Nothing + _ -> NullableNonEmptyString (Just str) + +newtype Default = Default Int + deriving (Eq, Show) + +instance ToJSON Default where + toJSON (Default i) = toJSON i + toEncoding (Default i) = toEncoding i + omitField (Default i) = i == 0 + +instance FromJSON Default where + parseJSON = fmap Default . parseJSON + omittedField = Just (Default 0) + +------------------------------------------------------------------------------- +-- Records +------------------------------------------------------------------------------- + +-- lax +data RecordA = RecordA + { required :: String + , optional :: NullableNonEmptyString + , default_ :: Default + } + deriving (Eq, Show, Generic) + +-- strict +data RecordB = RecordB + { required :: String + , optional :: NullableNonEmptyString + , default_ :: Default + } + deriving (Eq, Show, Generic) + +-- default +data RecordC = RecordC + { required :: String + , optional :: NullableNonEmptyString + , default_ :: Default + } + deriving (Eq, Show, Generic) + +data HRecordA a = HRecordA + { required :: String + , optional :: a + , default_ :: Default + } + deriving (Eq, Show, Generic1) + +data HRecordB a = HRecordB + { required :: String + , optional :: a + , default_ :: Default + } + deriving (Eq, Show, Generic1) + +data HRecordC a = HRecordC + { required :: String + , optional :: a + , default_ :: Default + } + deriving (Eq, Show, Generic1) + +type HRecordA' = HRecordA NullableNonEmptyString +type HRecordB' = HRecordB NullableNonEmptyString +type HRecordC' = HRecordC NullableNonEmptyString + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- + +nonOmittingOptions :: Options +nonOmittingOptions = defaultOptions { omitNothingFields = False, allowOmittedFields = False } + +omittingOptions :: Options +omittingOptions = defaultOptions { omitNothingFields = True, allowOmittedFields = True } + +------------------------------------------------------------------------------- +-- Test utils +------------------------------------------------------------------------------- + +encodeCase :: HasCallStack => ToJSON a => a -> Value -> IO () +encodeCase record obj = do + decode @Value (encode record) @?= Just obj + decode @Value (encode (toJSON record)) @?= Just obj + +decodeCase :: forall a. HasCallStack => (FromJSON a, Eq a, Show a) => a -> Value -> IO () +decodeCase record obj = do + decode @a (encode obj) @?= Just record + +counterCase :: forall a proxy. HasCallStack => (FromJSON a, ToJSON a, Show a) => proxy a -> Value -> IO () +counterCase _ obj = case decode @a (encode obj) of + Nothing -> return () + Just v -> assertFailure $ "decode should fail, got: " ++ show v + +------------------------------------------------------------------------------- +-- Test inputs +------------------------------------------------------------------------------- + +helloWorldRecA :: RecordA +helloWorldRecA = RecordA "hello" (nne "world") (Default 42) + +helloWorldRecB :: RecordB +helloWorldRecB = RecordB "hello" (nne "world") (Default 42) + +helloWorldRecC :: RecordC +helloWorldRecC = RecordC "hello" (nne "world") (Default 42) + +helloWorldHRecA :: HRecordA NullableNonEmptyString +helloWorldHRecA = HRecordA "hello" (nne "world") (Default 42) + +helloWorldHRecB :: HRecordB NullableNonEmptyString +helloWorldHRecB = HRecordB "hello" (nne "world") (Default 42) + +helloWorldHRecC :: HRecordC NullableNonEmptyString +helloWorldHRecC = HRecordC "hello" (nne "world") (Default 42) + +helloWorldObj :: Value +helloWorldObj = object + [ "required" .= String "hello" + , "optional" .= String "world" + , "default_" .= Number 42 + ] + +helloRecA :: RecordA +helloRecA = RecordA "hello" defaultNullableNonEmptyString (Default 0) + +helloRecB :: RecordB +helloRecB = RecordB "hello" defaultNullableNonEmptyString (Default 0) + +helloRecC :: RecordC +helloRecC = RecordC "hello" defaultNullableNonEmptyString (Default 0) + +helloHRecA :: HRecordA NullableNonEmptyString +helloHRecA = HRecordA "hello" defaultNullableNonEmptyString (Default 0) + +helloHRecB :: HRecordB NullableNonEmptyString +helloHRecB = HRecordB "hello" defaultNullableNonEmptyString (Default 0) + +helloHRecC :: HRecordC NullableNonEmptyString +helloHRecC = HRecordC "hello" defaultNullableNonEmptyString (Default 0) + +helloObj :: Value +helloObj = object + [ "required" .= String "hello" + ] + +helloNullObj :: Value +helloNullObj = object + [ "required" .= String "hello" + , "optional" .= Null + , "default_" .= Number 0 + ] + +helloNullObj2 :: Value +helloNullObj2 = object + [ "required" .= String "hello" + , "optional" .= Null + , "default_" .= Null + ] diff --git a/tests/UnitTests/OptionalFields/Generics.hs b/tests/UnitTests/OptionalFields/Generics.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OptionalFields/Generics.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module UnitTests.OptionalFields.Generics (omitGenerics) where + +import UnitTests.OptionalFields.Common + +------------------------------------------------------------------------------- +-- Ordinary +------------------------------------------------------------------------------- + +instance ToJSON RecordA where + toJSON = genericToJSON omittingOptions + toEncoding = genericToEncoding omittingOptions + +instance FromJSON RecordA where + parseJSON = genericParseJSON omittingOptions + +instance ToJSON RecordB where + toJSON = genericToJSON nonOmittingOptions + toEncoding = genericToEncoding nonOmittingOptions + +instance FromJSON RecordB where + parseJSON = genericParseJSON nonOmittingOptions + +instance ToJSON RecordC where + toJSON = genericToJSON defaultOptions + toEncoding = genericToEncoding defaultOptions + +instance FromJSON RecordC where + parseJSON = genericParseJSON defaultOptions + +------------------------------------------------------------------------------- +-- Higher +------------------------------------------------------------------------------- + +instance ToJSON1 HRecordA where + liftToJSON = genericLiftToJSON omittingOptions + liftToEncoding = genericLiftToEncoding omittingOptions + +instance FromJSON1 HRecordA where + liftParseJSON = genericLiftParseJSON omittingOptions + +instance ToJSON a => ToJSON (HRecordA a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordA a) where + parseJSON = parseJSON1 + + +instance ToJSON1 HRecordB where + liftToJSON = genericLiftToJSON nonOmittingOptions + liftToEncoding = genericLiftToEncoding nonOmittingOptions + +instance FromJSON1 HRecordB where + liftParseJSON = genericLiftParseJSON nonOmittingOptions + +instance ToJSON a => ToJSON (HRecordB a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordB a) where + parseJSON = parseJSON1 + + +instance ToJSON1 HRecordC where + liftToJSON = genericLiftToJSON defaultOptions + liftToEncoding = genericLiftToEncoding defaultOptions + +instance FromJSON1 HRecordC where + liftParseJSON = genericLiftParseJSON defaultOptions + +instance ToJSON a => ToJSON (HRecordC a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordC a) where + parseJSON = parseJSON1 + +------------------------------------------------------------------------------- +-- Tests +------------------------------------------------------------------------------- + +omitGenerics :: TestTree +omitGenerics = testGroup "Omit optional fields (Generics)" + [ testGroup "ordinary" + [ testGroup "omitNothingFields = True" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordA) helloNullObj2 + ] + , testGroup "omitNothingFields = False" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @RecordB) helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordB) helloNullObj2 -- fails because Default instance expects only numbers + ] + , testGroup "defaultOptions" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordC) helloNullObj2 + ] + ] + , testGroup "higher" + [ testGroup "omitNothingFields = True, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloHRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordA') helloNullObj2 + ] + , testGroup "omitNothingFields = False, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @HRecordB') helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordB') helloNullObj2 + ] + , testGroup "defaultOptions, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordC') helloNullObj2 + ] + ] + ] diff --git a/tests/UnitTests/OptionalFields/Manual.hs b/tests/UnitTests/OptionalFields/Manual.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OptionalFields/Manual.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module UnitTests.OptionalFields.Manual (omitManual) where + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + +import UnitTests.OptionalFields.Common + +------------------------------------------------------------------------------- +-- Ordinary +------------------------------------------------------------------------------- + +-- lax +instance ToJSON RecordA where + toJSON RecordA {..} = Object $ "required" .?= required <> "optional" .?= optional <> "default_" .?= default_ + toEncoding RecordA {..} = pairs $ "required" .?= required <> "optional" .?= optional <> "default_" .?= default_ + +instance FromJSON RecordA where + parseJSON = withObject "RecordA" $ \obj -> pure RecordA + <*> obj .:!= "required" + <*> obj .:!= "optional" + <*> obj .:!= "default_" + +-- strict +instance ToJSON RecordB where + toJSON RecordB {..} = Object $ "required" .= required <> "optional" .= optional <> "default_" .= default_ + toEncoding RecordB {..} = pairs $ "required" .= required <> "optional" .= optional <> "default_" .= default_ + +instance FromJSON RecordB where + parseJSON = withObject "RecordB" $ \obj -> pure RecordB + <*> obj .: "required" + <*> obj .: "optional" + <*> obj .: "default_" + +-- default: encoding strict, decoding lax +instance ToJSON RecordC where + toJSON RecordC {..} = Object $ "required" .= required <> "optional" .= optional <> "default_" .= default_ + toEncoding RecordC {..} = pairs $ "required" .= required <> "optional" .= optional <> "default_" .= default_ + +instance FromJSON RecordC where + parseJSON = withObject "RecordC" $ \obj -> pure RecordC + <*> obj .:!= "required" + <*> obj .:!= "optional" + <*> obj .:!= "default_" + +------------------------------------------------------------------------------- +-- Higher +------------------------------------------------------------------------------- + +instance ToJSON1 HRecordA where + liftToJSON o f _ HRecordA {..} = Object $ "required" .?= required <> explicitToFieldOmit o f "optional" optional <> "default_" .?= default_ + liftToEncoding o f _ HRecordA {..} = pairs $ "required" .?= required <> explicitToFieldOmit o f "optional" optional <> "default_" .?= default_ + +instance ToJSON a => ToJSON (HRecordA a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON1 HRecordA where + liftParseJSON o f _ = withObject "HRecordA" $ \obj -> pure HRecordA + <*> obj .:!= "required" + <*> explicitParseFieldOmit o f obj "optional" + <*> obj .:!= "default_" + +instance FromJSON a => FromJSON (HRecordA a) where + parseJSON = parseJSON1 + + +instance ToJSON1 HRecordB where + liftToJSON _o f _ HRecordB {..} = Object $ "required" .= required <> explicitToField f "optional" optional <> "default_" .= default_ + liftToEncoding _o f _ HRecordB {..} = pairs $ "required" .= required <> explicitToField f "optional" optional <> "default_" .= default_ + +instance ToJSON a => ToJSON (HRecordB a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON1 HRecordB where + liftParseJSON _o f _ = withObject "HRecordB" $ \obj -> pure HRecordB + <*> obj .: "required" + <*> explicitParseField f obj "optional" + <*> obj .: "default_" + +instance FromJSON a => FromJSON (HRecordB a) where + parseJSON = parseJSON1 + + +instance ToJSON1 HRecordC where + liftToJSON _o f _ HRecordC {..} = Object $ "required" .= required <> explicitToField f "optional" optional <> "default_" .= default_ + liftToEncoding _o f _ HRecordC {..} = pairs $ "required" .= required <> explicitToField f "optional" optional <> "default_" .= default_ + +instance ToJSON a => ToJSON (HRecordC a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON1 HRecordC where + liftParseJSON o f _ = withObject "HRecordC" $ \obj -> pure HRecordC + <*> obj .:!= "required" + <*> explicitParseFieldOmit o f obj "optional" + <*> obj .:!= "default_" + +instance FromJSON a => FromJSON (HRecordC a) where + parseJSON = parseJSON1 + +------------------------------------------------------------------------------- +-- Tests +------------------------------------------------------------------------------- + +omitManual :: TestTree +omitManual = testGroup "Omit optional fields (Manual)" + [ testGroup "ordinary" + [ testGroup "omitNothingFields = True" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordA) helloNullObj2 + ] + , testGroup "omitNothingFields = False" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @RecordB) helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordB) helloNullObj2 -- fails because Default instance expects only numbers + ] + , testGroup "defaultOptions" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordC) helloNullObj2 + ] + ] + , testGroup "higher" + [ testGroup "omitNothingFields = True, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloHRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordA') helloNullObj2 + ] + , testGroup "omitNothingFields = False, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @HRecordB') helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordB') helloNullObj2 + ] + , testGroup "defaultOptions, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordC') helloNullObj2 + ] + ] + ] diff --git a/tests/UnitTests/OptionalFields/TH.hs b/tests/UnitTests/OptionalFields/TH.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/OptionalFields/TH.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module UnitTests.OptionalFields.TH (omitTH) where + +import UnitTests.OptionalFields.Common + +$(deriveJSON omittingOptions ''RecordA) +$(deriveJSON nonOmittingOptions ''RecordB) +$(deriveJSON defaultOptions ''RecordC) +$(deriveJSON1 omittingOptions ''HRecordA) +$(deriveJSON1 nonOmittingOptions ''HRecordB) +$(deriveJSON1 defaultOptions ''HRecordC) + + +instance ToJSON a => ToJSON (HRecordA a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordA a) where + parseJSON = parseJSON1 + +instance ToJSON a => ToJSON (HRecordB a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordB a) where + parseJSON = parseJSON1 + +instance ToJSON a => ToJSON (HRecordC a) where + toJSON = toJSON1 + toEncoding = toEncoding1 + +instance FromJSON a => FromJSON (HRecordC a) where + parseJSON = parseJSON1 + + + +omitTH :: TestTree +omitTH = testGroup "Omit optional fields (TH)" + [ testGroup "ordinary" + [ testGroup "omitNothingFields = True" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordA) helloNullObj2 + ] + , testGroup "omitNothingFields = False" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @RecordB) helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordB) helloNullObj2 -- fails because Default instance expects only numbers + ] + , testGroup "defaultOptions" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @RecordC) helloNullObj2 + ] + ] + , testGroup "higher" + [ testGroup "omitNothingFields = True, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecA helloWorldObj + , testCase "JSON should not include optional value." $ encodeCase helloHRecA helloObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecA helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecA helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecA helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordA') helloNullObj2 + ] + , testGroup "omitNothingFields = False, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecB helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecB helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecB helloWorldObj + , testCase "JSON decode not including optional value" $ counterCase (Proxy @HRecordB') helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecB helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordB') helloNullObj2 + ] + , testGroup "defaultOptions, higher" + [ testCase "JSON should include non-optional value." $ encodeCase helloWorldHRecC helloWorldObj + , testCase "JSON should include optional value." $ encodeCase helloHRecC helloNullObj + , testCase "JSON decode including non-optional value" $ decodeCase helloWorldHRecC helloWorldObj + , testCase "JSON decode not including optional value" $ decodeCase helloHRecC helloObj + , testCase "JSON decode including optional value" $ decodeCase helloHRecC helloNullObj + , testCase "JSON decode including optional value 2" $ counterCase (Proxy @HRecordC') helloNullObj2 + ] + ] + ] diff --git a/tests/UnitTests/UTCTime.hs b/tests/UnitTests/UTCTime.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/UTCTime.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +module UnitTests.UTCTime (utcTimeTests) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, testCaseSteps, Assertion, assertEqual, assertFailure) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime, ZonedTime) +import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale) + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + +import Data.Aeson + +-- Test decoding various UTC time formats +utcTimeGood :: Assertion +utcTimeGood = do + let ts1 = "2015-01-01T12:13:00.00Z" + let ts2 = "2015-01-01T12:13:00Z" + -- 'T' between date and time is not required, can be space + let ts3 = "2015-01-03 12:13:00.00Z" + let ts4 = "2015-01-03 12:13:00.125Z" + t1 <- parseWithAeson ts1 + t2 <- parseWithAeson ts2 + t3 <- parseWithAeson ts3 + t4 <- parseWithAeson ts4 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2 + assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3 + assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4 + -- Time zones. Both +HHMM and +HH:MM are allowed for timezone + -- offset, and MM may be omitted. + let ts5 = "2015-01-01T12:30:00.00+00" + let ts6 = "2015-01-01T12:30:00.00+01:15" + let ts7 = "2015-01-01T12:30:00.00-02" + let ts8 = "2015-01-01T22:00:00.00-03" + let ts9 = "2015-01-01T22:00:00.00-04:30" + t5 <- parseWithAeson ts5 + t6 <- parseWithAeson ts6 + t7 <- parseWithAeson ts7 + t8 <- parseWithAeson ts8 + t9 <- parseWithAeson ts9 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7 + -- ts8 wraps around to the next day in UTC + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9 + + -- Seconds in Time can be omitted + let ts10 = "2015-01-03T12:13Z" + let ts11 = "2015-01-03 12:13Z" + let ts12 = "2015-01-01T12:30-02" + t10 <- parseWithAeson ts10 + t11 <- parseWithAeson ts11 + t12 <- parseWithAeson ts12 + assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10 + assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12 + + -- leap seconds are included correctly + let ts13 = "2015-08-23T23:59:60.128+00" + t13 <- parseWithAeson ts13 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.128Z") t13 + let ts14 = "2015-08-23T23:59:60.999999999999+00" + t14 <- parseWithAeson ts14 + assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.999999999999Z") t14 + + where + parseWithRead :: String -> LT.Text -> UTCTime + parseWithRead f s = + fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s + + parseWithAeson :: LT.Text -> IO UTCTime + parseWithAeson s = either fail return . eitherDecode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] + +-- Test that a few non-timezone qualified timestamp formats get +-- rejected if decoding to UTCTime. +utcTimeBad :: (String -> IO ()) -> Assertion +utcTimeBad info = do + verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required) + verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required) + verifyFailParse "2000-01-01" -- date only not OK + verifyFailParse "2000-01-01Z" -- date only not OK + verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given + verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given + verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits + verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds + verifyFailParse "2015-01-03 23:59:61Z" -- exceeds allowed seconds per day + verifyFailParse "2015-01-03 12:13:00 Z" -- space before Zulu + verifyFailParse "2015-01-03 12:13:00 +00:00" -- space before offset + where + verifyFailParse :: LT.Text -> Assertion + verifyFailParse s = do + info (LT.unpack s) + let bs = LT.encodeUtf8 $ LT.concat ["\"", s, "\""] + let decU = decode bs :: Maybe UTCTime + let decZ = decode bs :: Maybe ZonedTime + assertIsNothing "verify failure UTCTime" decU + assertIsNothing "verify failure ZonedTime" decZ + +assertIsNothing :: Show a => String -> Maybe a -> Assertion +assertIsNothing _ Nothing = return () +assertIsNothing err (Just a) = assertFailure $ err ++ " " ++ show a + +utcTimeTests :: TestTree +utcTimeTests = testGroup "utctime" [ + testCase "good" utcTimeGood + , testCaseSteps "bad" utcTimeBad + ] diff --git a/tests/golden/generic.expected b/tests/golden/generic.expected --- a/tests/golden/generic.expected +++ b/tests/golden/generic.expected @@ -19,9 +19,9 @@ Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs Error in $: parsing Types.SomeType failed, expected Object, but encountered Array -Error in $: not enough input. Expecting ':' -Error in $: not enough input. Expecting object value -Error in $: not enough input. Expecting ',' or '}' +Unexpected end-of-input, expecting : +Unexpected end-of-input, expecting JSON value +Unexpected end-of-input, expecting , or } SomeType (two-element array) Error in $[1]: parsing Int failed, expected Number, but encountered Boolean Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null @@ -29,8 +29,8 @@ Error in $[0]: parsing Types.SomeType failed, tag element is not a String Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0 Error in $: parsing Types.SomeType failed, expected Array, but encountered Object -Error in $: not enough input. Expecting ',' or ']' -Error in $: not enough input. Expecting json list value +Unexpected end-of-input, expecting , or ] +Unexpected end-of-input, expecting JSON value SomeType (reject unknown fields) Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"] Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found diff --git a/tests/golden/th.expected b/tests/golden/th.expected --- a/tests/golden/th.expected +++ b/tests/golden/th.expected @@ -19,9 +19,9 @@ Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 2 pairs. Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 0 pairs. Error in $: When parsing Types.SomeType expected Object but got Array. -Error in $: not enough input. Expecting ':' -Error in $: not enough input. Expecting object value -Error in $: not enough input. Expecting ',' or '}' +Unexpected end-of-input, expecting : +Unexpected end-of-input, expecting JSON value +Unexpected end-of-input, expecting , or } SomeType (two-element array) Error in $: parsing Int failed, expected Number, but encountered Boolean Error in $: When parsing the constructor Record of type Types.SomeType expected Object but got Null. @@ -29,8 +29,8 @@ Error in $: When parsing Types.SomeType expected an Array of 2 elements where the first element is a String but got Null at the first element. Error in $: When parsing Types.SomeType expected an Array of 2 elements but got 0 elements Error in $: When parsing Types.SomeType expected Array but got Object. -Error in $: not enough input. Expecting ',' or ']' -Error in $: not enough input. Expecting json list value +Unexpected end-of-input, expecting , or ] +Unexpected end-of-input, expecting JSON value SomeType (reject unknown fields) Error in $: Unknown fields: ["testZero"] Error in $: key "tag" not found