{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Thyme.Format.Aeson
( DotNetTime (..)
) where
import Prelude
import Control.Applicative
import Data.Aeson hiding (DotNetTime (..))
import Data.Aeson.Types hiding (DotNetTime (..))
import Data.Data
import Data.Monoid
import Data.Text (pack, unpack)
import qualified Data.Text as T
import Data.Thyme
import System.Locale
newtype DotNetTime = DotNetTime {
DotNetTime -> UTCTime
fromDotNetTime :: UTCTime
} deriving (DotNetTime -> DotNetTime -> Bool
(DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool) -> Eq DotNetTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotNetTime -> DotNetTime -> Bool
$c/= :: DotNetTime -> DotNetTime -> Bool
== :: DotNetTime -> DotNetTime -> Bool
$c== :: DotNetTime -> DotNetTime -> Bool
Eq, Eq DotNetTime
Eq DotNetTime =>
(DotNetTime -> DotNetTime -> Ordering)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> Bool)
-> (DotNetTime -> DotNetTime -> DotNetTime)
-> (DotNetTime -> DotNetTime -> DotNetTime)
-> Ord DotNetTime
DotNetTime -> DotNetTime -> Bool
DotNetTime -> DotNetTime -> Ordering
DotNetTime -> DotNetTime -> DotNetTime
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DotNetTime -> DotNetTime -> DotNetTime
$cmin :: DotNetTime -> DotNetTime -> DotNetTime
max :: DotNetTime -> DotNetTime -> DotNetTime
$cmax :: DotNetTime -> DotNetTime -> DotNetTime
>= :: DotNetTime -> DotNetTime -> Bool
$c>= :: DotNetTime -> DotNetTime -> Bool
> :: DotNetTime -> DotNetTime -> Bool
$c> :: DotNetTime -> DotNetTime -> Bool
<= :: DotNetTime -> DotNetTime -> Bool
$c<= :: DotNetTime -> DotNetTime -> Bool
< :: DotNetTime -> DotNetTime -> Bool
$c< :: DotNetTime -> DotNetTime -> Bool
compare :: DotNetTime -> DotNetTime -> Ordering
$ccompare :: DotNetTime -> DotNetTime -> Ordering
$cp1Ord :: Eq DotNetTime
Ord, ReadPrec [DotNetTime]
ReadPrec DotNetTime
Int -> ReadS DotNetTime
ReadS [DotNetTime]
(Int -> ReadS DotNetTime)
-> ReadS [DotNetTime]
-> ReadPrec DotNetTime
-> ReadPrec [DotNetTime]
-> Read DotNetTime
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DotNetTime]
$creadListPrec :: ReadPrec [DotNetTime]
readPrec :: ReadPrec DotNetTime
$creadPrec :: ReadPrec DotNetTime
readList :: ReadS [DotNetTime]
$creadList :: ReadS [DotNetTime]
readsPrec :: Int -> ReadS DotNetTime
$creadsPrec :: Int -> ReadS DotNetTime
Read, Int -> DotNetTime -> ShowS
[DotNetTime] -> ShowS
DotNetTime -> String
(Int -> DotNetTime -> ShowS)
-> (DotNetTime -> String)
-> ([DotNetTime] -> ShowS)
-> Show DotNetTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotNetTime] -> ShowS
$cshowList :: [DotNetTime] -> ShowS
show :: DotNetTime -> String
$cshow :: DotNetTime -> String
showsPrec :: Int -> DotNetTime -> ShowS
$cshowsPrec :: Int -> DotNetTime -> ShowS
Show, Typeable, TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
(TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime DotNetTime
forall t.
(TimeLocale -> t -> (Char -> ShowS) -> Char -> ShowS)
-> FormatTime t
showsTime :: TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
$cshowsTime :: TimeLocale -> DotNetTime -> (Char -> ShowS) -> Char -> ShowS
FormatTime)
instance ToJSON DotNetTime where
toJSON :: DotNetTime -> Value
toJSON (DotNetTime t :: UTCTime
t) =
Text -> Value
String (String -> Text
pack (String
secs String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. FormatTime t => t -> String
formatMillis UTCTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")/"))
where secs :: String
secs = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "/Date(%s" UTCTime
t
{-# INLINE toJSON #-}
instance FromJSON DotNetTime where
parseJSON :: Value -> Parser DotNetTime
parseJSON = String -> (Text -> Parser DotNetTime) -> Value -> Parser DotNetTime
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText "DotNetTime" ((Text -> Parser DotNetTime) -> Value -> Parser DotNetTime)
-> (Text -> Parser DotNetTime) -> Value -> Parser DotNetTime
forall a b. (a -> b) -> a -> b
$ \t :: Text
t ->
let (s :: Text
s,m :: Text
m) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- 5) Text
t
t' :: Text
t' = [Text] -> Text
T.concat [Text
s,".",Text
m]
in case TimeLocale -> String -> String -> Maybe UTCTime
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale "/Date(%s%Q)/" (Text -> String
unpack Text
t') of
Just d :: UTCTime
d -> DotNetTime -> Parser DotNetTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> DotNetTime
DotNetTime UTCTime
d)
_ -> String -> Parser DotNetTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "could not parse .NET time"
{-# INLINE parseJSON #-}
instance ToJSON ZonedTime where
toJSON :: ZonedTime -> Value
toJSON t :: ZonedTime
t = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format ZonedTime
t
where
format :: String
format = "%FT%T." String -> ShowS
forall a. [a] -> [a] -> [a]
++ ZonedTime -> String
forall t. FormatTime t => t -> String
formatMillis ZonedTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tzFormat
tzFormat :: String
tzFormat
| 0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
t) = "Z"
| Bool
otherwise = "%z"
formatMillis :: (FormatTime t) => t -> String
formatMillis :: t -> String
formatMillis t :: t
t = Int -> ShowS
forall a. Int -> [a] -> [a]
take 3 ShowS -> (t -> String) -> t -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%q" (t -> String) -> t -> String
forall a b. (a -> b) -> a -> b
$ t
t
instance FromJSON ZonedTime where
parseJSON :: Value -> Parser ZonedTime
parseJSON (String t :: Text
t) =
[String] -> Parser ZonedTime
tryFormats [String]
alternateFormats
Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser ZonedTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "could not parse ECMA-262 ISO-8601 date"
where
tryFormat :: String -> f a
tryFormat f :: String
f =
case TimeLocale -> String -> String -> Maybe a
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
f (Text -> String
unpack Text
t) of
Just d :: a
d -> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
Nothing -> f a
forall (f :: * -> *) a. Alternative f => f a
empty
tryFormats :: [String] -> Parser ZonedTime
tryFormats = (Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime)
-> [Parser ZonedTime] -> Parser ZonedTime
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Parser ZonedTime -> Parser ZonedTime -> Parser ZonedTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Parser ZonedTime] -> Parser ZonedTime)
-> ([String] -> [Parser ZonedTime]) -> [String] -> Parser ZonedTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Parser ZonedTime) -> [String] -> [Parser ZonedTime]
forall a b. (a -> b) -> [a] -> [b]
map String -> Parser ZonedTime
forall a (f :: * -> *).
(ParseTime a, Alternative f) =>
String -> f a
tryFormat
alternateFormats :: [String]
alternateFormats =
TimeLocale -> String
dateTimeFmt TimeLocale
defaultTimeLocale String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
[String] -> [String] -> [String]
forall (t :: * -> *) a. (Foldable t, Monoid a) => t a -> [a] -> [a]
distributeList ["%Y", "%Y-%m", "%F"]
["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
distributeList :: t a -> [a] -> [a]
distributeList xs :: t a
xs ys :: [a]
ys =
(a -> [a] -> [a]) -> [a] -> t a -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x :: a
x acc :: [a]
acc -> [a]
acc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a] -> [a]
forall b. Monoid b => b -> [b] -> [b]
distribute a
x [a]
ys) [] t a
xs
distribute :: b -> [b] -> [b]
distribute x :: b
x = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
x)
parseJSON v :: Value
v = String -> Value -> Parser ZonedTime
forall a. String -> Value -> Parser a
typeMismatch "ZonedTime" Value
v
instance ToJSON UTCTime where
toJSON :: UTCTime -> Value
toJSON t :: UTCTime
t = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format UTCTime
t
where
format :: String
format = "%FT%T." String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall t. FormatTime t => t -> String
formatMillis UTCTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Z"
{-# INLINE toJSON #-}
instance FromJSON UTCTime where
parseJSON :: Value -> Parser UTCTime
parseJSON = String -> (Text -> Parser UTCTime) -> Value -> Parser UTCTime
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText "UTCTime" ((Text -> Parser UTCTime) -> Value -> Parser UTCTime)
-> (Text -> Parser UTCTime) -> Value -> Parser UTCTime
forall a b. (a -> b) -> a -> b
$ \t :: Text
t ->
case TimeLocale -> String -> String -> Maybe UTCTime
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale "%FT%T%QZ" (Text -> String
unpack Text
t) of
Just d :: UTCTime
d -> UTCTime -> Parser UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
d
_ -> String -> Parser UTCTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "could not parse ISO-8601 date"
{-# INLINE parseJSON #-}