{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#if HLINT
#include "cabal_macros.h"
#endif
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
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Text (pack, unpack)
import qualified Data.Text as T
import Data.Thyme
newtype DotNetTime = DotNetTime {
DotNetTime -> UTCTime
fromDotNetTime :: UTCTime
} deriving (DotNetTime -> DotNetTime -> Bool
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
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
Ord, ReadPrec [DotNetTime]
ReadPrec DotNetTime
Int -> ReadS DotNetTime
ReadS [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
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
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 UTCTime
t) =
Text -> Value
String (String -> Text
pack (String
secs forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis UTCTime
t forall a. [a] -> [a] -> [a]
++ String
")/"))
where secs :: String
secs = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"/Date(%s" UTCTime
t
{-# INLINE toJSON #-}
instance FromJSON DotNetTime where
parseJSON :: Value -> Parser DotNetTime
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"DotNetTime" forall a b. (a -> b) -> a -> b
$ \Text
t ->
let (Text
s,Text
m) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
t forall a. Num a => a -> a -> a
- Int
5) Text
t
t' :: Text
t' = [Text] -> Text
T.concat [Text
s,Text
".",Text
m]
in case forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
"/Date(%s%Q)/" (Text -> String
unpack Text
t') of
Just UTCTime
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> DotNetTime
DotNetTime UTCTime
d)
Maybe UTCTime
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse .NET time"
{-# INLINE parseJSON #-}
instance ToJSON ZonedTime where
toJSON :: ZonedTime -> Value
toJSON ZonedTime
t = Text -> Value
String forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format ZonedTime
t
where
format :: String
format = String
"%FT%T." forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis ZonedTime
t forall a. [a] -> [a] -> [a]
++ String
tzFormat
tzFormat :: String
tzFormat
| Int
0 forall a. Eq a => a -> a -> Bool
== TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
t) = String
"Z"
| Bool
otherwise = String
"%z"
formatMillis :: (FormatTime t) => t -> String
formatMillis :: forall t. FormatTime t => t -> String
formatMillis t
t = forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%q" t
t
instance FromJSON ZonedTime where
parseJSON :: Value -> Parser ZonedTime
parseJSON (String Text
t) =
[String] -> Parser ZonedTime
tryFormats [String]
alternateFormats
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse ECMA-262 ISO-8601 date"
where
tryFormat :: String -> f a
tryFormat String
f =
case forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
f (Text -> String
unpack Text
t) of
Just a
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
Maybe a
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
tryFormats :: [String] -> Parser ZonedTime
tryFormats = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {f :: * -> *}.
(ParseTime a, Alternative f) =>
String -> f a
tryFormat
alternateFormats :: [String]
alternateFormats =
TimeLocale -> String
dateTimeFmt TimeLocale
defaultTimeLocale forall a. a -> [a] -> [a]
:
forall {t :: * -> *} {a}.
(Foldable t, Monoid a) =>
t a -> [a] -> [a]
distributeList [String
"%Y", String
"%Y-%m", String
"%F"]
[String
"T%R", String
"T%T", String
"T%T%Q", String
"T%T%QZ", String
"T%T%Q%z"]
distributeList :: t a -> [a] -> [a]
distributeList t a
xs [a]
ys =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
acc -> [a]
acc forall a. [a] -> [a] -> [a]
++ forall {b}. Monoid b => b -> [b] -> [b]
distribute a
x [a]
ys) [] t a
xs
distribute :: b -> [b] -> [b]
distribute b
x = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Monoid a => a -> a -> a
mappend b
x)
parseJSON Value
v = forall a. String -> Value -> Parser a
typeMismatch String
"ZonedTime" Value
v
instance ToJSON UTCTime where
toJSON :: UTCTime -> Value
toJSON UTCTime
t = Text -> Value
String forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
format UTCTime
t
where
format :: String
format = String
"%FT%T." forall a. [a] -> [a] -> [a]
++ forall t. FormatTime t => t -> String
formatMillis UTCTime
t forall a. [a] -> [a] -> [a]
++ String
"Z"
{-# INLINE toJSON #-}
instance FromJSON UTCTime where
parseJSON :: Value -> Parser UTCTime
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"UTCTime" forall a b. (a -> b) -> a -> b
$ \Text
t ->
case forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
defaultTimeLocale String
"%FT%T%QZ" (Text -> String
unpack Text
t) of
Just UTCTime
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
d
Maybe UTCTime
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not parse ISO-8601 date"
{-# INLINE parseJSON #-}