Commits

Mike Burns  committed d007962

parseJSON for the variations on ISO-8601 dates as listed in ECMA-262.

  • Participants
  • Parent commits d84792b

Comments (0)

Files changed (3)

File Data/Aeson/Types/Class.hs

 {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
     GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
-    OverloadedStrings, UndecidableInstances, ViewPatterns #-}
+    OverloadedStrings, UndecidableInstances, ViewPatterns,
+    StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 #ifdef GENERICS
 {-# LANGUAGE DefaultSignatures #-}
     , typeMismatch
     ) where
 
-import Control.Applicative ((<$>), (<*>), pure)
+import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
 import Data.Aeson.Functions
 import Data.Aeson.Types.Internal
 import Data.Attoparsec.Char8 (Number(..))
 import Data.Hashable (Hashable(..))
 import Data.Int (Int8, Int16, Int32, Int64)
 import Data.Maybe (fromMaybe)
-import Data.Monoid (Dual(..), First(..), Last(..))
+import Data.Monoid (Dual(..), First(..), Last(..), mappend)
 import Data.Ratio (Ratio)
 import Data.Text (Text, pack, unpack)
 import Data.Text.Encoding (encodeUtf8)
-import Data.Time.Clock (UTCTime)
+import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
 import Data.Time.Format (FormatTime, formatTime, parseTime)
 import Data.Traversable (traverse)
 import Data.Typeable (Typeable)
     parseJSON v   = typeMismatch "DotNetTime" v
     {-# INLINE parseJSON #-}
 
+deriving instance Eq ZonedTime
+
+instance ToJSON ZonedTime where
+  toJSON t = String $ pack $ formattedTime
+    where
+      formattedTime
+        | 0 == timeZoneMinutes (zonedTimeZone t) =
+          formatTime defaultTimeLocale "%FT%T%QZ" t
+        | otherwise =
+          formatTime defaultTimeLocale "%FT%T%Q%z" t
+
+instance FromJSON ZonedTime where
+  parseJSON (String t) =
+    tryFormats alternateFormats
+    <|> fail "could not parse ECMA-262 ISO-8601 date"
+    where
+      tryFormat f =
+        case parseTime defaultTimeLocale f (unpack t) of
+          Just d -> pure d
+          Nothing -> empty
+      tryFormats = foldr1 (<|>) . map tryFormat
+      alternateFormats =
+        distributeList ["%Y", "%Y-%m", "%F"]
+                       ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
+
+      distributeList xs ys =
+        foldr (\x acc -> acc ++ distribute x ys) [] xs
+      distribute x = map (mappend x)
+
+  parseJSON v = typeMismatch "ZonedTime" v
+
 instance ToJSON UTCTime where
     toJSON t = String (pack (take 23 str ++ "Z"))
       where str = formatTime defaultTimeLocale "%FT%T%Q" t
     template-haskell,
     test-framework,
     test-framework-quickcheck2,
-    text
+    text,
+    time
 
 source-repository head
   type:     git

File tests/Properties.hs

 import Data.Text (Text)
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck (Arbitrary(..))
+import Test.QuickCheck (Arbitrary(..), choose, Gen)
 import qualified Data.Aeson.Generic as G
 import qualified Data.Attoparsec.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Text as T
 import qualified Data.Map as Map
+import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), hoursToTimeZone, Day(..), TimeOfDay(..))
 
 encodeDouble :: Double -> Double -> Bool
 encodeDouble num denom
 instance Arbitrary Foo where
     arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
 
+instance Arbitrary LocalTime where
+    arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)
+
+instance Arbitrary TimeZone where
+    arbitrary = do
+      offset <- choose (0,2) :: Gen Int
+      return $ hoursToTimeZone offset
+
+instance Arbitrary ZonedTime where
+    arbitrary = liftM2 ZonedTime arbitrary arbitrary
+
 data UFoo = UFoo {
       _UFooInt :: Int
     , uFooInt :: Int
     , testProperty "String" $ roundTripEq (""::String)
     , testProperty "Text" $ roundTripEq T.empty
     , testProperty "Foo" $ roundTripEq (undefined::Foo)
+    , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
     ],
   testGroup "toFromJSON" [
       testProperty "Integer" (toFromJSON :: Integer -> Bool)