git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #486 from parsonsmatt/matt/add-bce-day-support

Add BCE day support

commit5f230ed189a9ac783f38e865fdb462c595aa9ded authorAdam Bergmark <adam@bergmark.nl> dateFri 16 Dec 2016, 16:59 (10 years ago) parent66a5b736654967
6 files changed+41−10
compare with master
unifiedsplit
Data/Aeson/Encoding/Builder.hs+7−6 Data/Aeson/Parser/Time.hs+4−2 changelog.md+1 tests/Properties.hs+1 tests/Types.hs+19−1 tests/UnitTests.hs+9−1
Data/Aeson/Encoding/Builder.hs+7−6
@@ -193,12 +193,13 @@ day dd = encodeYear yr <>
193193 !(T dh dl) = twoDigits d
194194 encodeYear y
195195 | y >= 1000 = B.integerDec y
196− | y > 0 =
197− let (ab,c) = fromIntegral y `quotRem` 10
198− (a,b) = ab `quotRem` 10
199− in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()
200− | otherwise =
201− error "Data.Aeson.Encode.Builder.day: years BCE not supported"
196+ | y >= 0 = BP.primBounded (ascii4 (padYear y)) ()
197+ | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) ()
198+ | otherwise = B.integerDec y
199+ padYear y =
200+ let (ab,c) = fromIntegral y `quotRem` 10
201+ (a,b) = ab `quotRem` 10
202+ in ('0',(digit a,(digit b,digit c)))
202203{-# INLINE day #-}
203204
204205timeOfDay :: TimeOfDay -> Builder
Data/Aeson/Parser/Time.hs+4−2
@@ -25,6 +25,7 @@ module Data.Aeson.Parser.Time
2525import Prelude ()
2626import Prelude.Compat
2727
28+import Control.Applicative ((<|>))
2829import Control.Monad (void, when)
2930import Data.Aeson.Internal.Time (toPico)
3031import Data.Attoparsec.Text as A
@@ -46,13 +47,14 @@ run p t = case A.parseOnly (p <* endOfInput) t of
4647 Left err -> fail $ "could not parse date: " ++ err
4748 Right r -> return r
4849
49−-- | Parse a date of the form @YYYY-MM-DD@.
50+-- | Parse a date of the form @[+,-]YYYY-MM-DD@.
5051day :: Parser Day
5152day = do
53+ absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id
5254 y <- decimal <* char '-'
5355 m <- twoDigits <* char '-'
5456 d <- twoDigits
55− maybe (fail "invalid date") return (fromGregorianValid y m d)
57+ maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)
5658
5759-- | Parse a two-digit integer (e.g. day of month, hour).
5860twoDigits :: Parser Int
changelog.md+1
@@ -27,6 +27,7 @@ categorised as follows:
2727 states that control characters must be escaped. (This may change at
2828 some point, but doesn't seem important.)
2929
30+- Days BCE are properly encoded.
3031
3132#### 1.0.2.1
3233
tests/Properties.hs+1
@@ -203,6 +203,7 @@ tests = testGroup "properties" [
203203 , testProperty "Lazy Text" $ roundTripEq LT.empty
204204 , testProperty "Foo" $ roundTripEq (undefined :: Foo)
205205 , testProperty "Day" $ roundTripEq (undefined :: Day)
206+ , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)
206207 , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
207208 , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)
208209 , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)
tests/Types.hs+19−1
@@ -15,9 +15,11 @@ import Data.Data
1515import Data.Functor.Compose (Compose (..))
1616import Data.Functor.Identity (Identity (..))
1717import Data.Text
18+import Data.Time (Day (..), fromGregorian)
1819import GHC.Generics
19−import Test.QuickCheck (Property, counterexample)
20+import Test.QuickCheck (Arbitrary (..), Property, counterexample)
2021import qualified Data.Map as Map
22+import Data.Aeson
2123
2224type I = Identity
2325type Compose3 f g h = Compose (Compose f g) h
@@ -115,3 +117,19 @@ deriving instance Generic EitherTextInt
115117failure :: Show a => String -> String -> a -> Property
116118failure func msg v = counterexample
117119 (func ++ " failed: " ++ msg ++ ", " ++ show v) False
120+
121+newtype BCEDay = BCEDay Day
122+ deriving (Eq, Show)
123+
124+zeroDay :: Day
125+zeroDay = fromGregorian 0 0 0
126+
127+instance Arbitrary BCEDay where
128+ arbitrary = fmap (BCEDay . ModifiedJulianDay . (+ toModifiedJulianDay zeroDay)) arbitrary
129+
130+instance ToJSON BCEDay where
131+ toJSON (BCEDay d) = toJSON d
132+ toEncoding (BCEDay d) = toEncoding d
133+
134+instance FromJSON BCEDay where
135+ parseJSON = fmap BCEDay . parseJSON
tests/UnitTests.hs+9−1
@@ -43,7 +43,7 @@ import Data.Scientific (Scientific)
4343import Data.Sequence (Seq)
4444import Data.Tagged (Tagged(..))
4545import Data.Text (Text)
46−import Data.Time (UTCTime)
46+import Data.Time (UTCTime, fromGregorian)
4747import Data.Time.Format (parseTime)
4848import Data.Time.Locale.Compat (defaultTimeLocale)
4949import Data.Word (Word8)
@@ -331,6 +331,8 @@ jsonDecodingExamples = [
331331 , MaybeExample "Word8 3.14" "3.14" (Nothing :: Maybe Word8)
332332 , MaybeExample "Word8 -1" "-1" (Nothing :: Maybe Word8)
333333 , MaybeExample "Word8 300" "300" (Nothing :: Maybe Word8)
334+ -- Negative zero year, encoding never produces such:
335+ , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))
334336 ]
335337
336338jsonExamples :: [Example]
@@ -396,6 +398,12 @@ jsonExamples =
396398 , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)
397399 , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])
398400
401+ , Example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)
402+ , Example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)
403+ , Example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)
404+ , Example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)
405+ , Example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)
406+
399407 , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)
400408 , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)
401409 , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)