{-# LANGUAGE CPP #-}
module Composite.Aeson.Formats.DateTime
( DateTimeFormat(..), regularDateTimeFormat
, dateTimeJsonFormat
, iso8601DateJsonFormat, iso8601DateTimeJsonFormat, iso8601TimeJsonFormat
) where
import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
import Composite.Aeson.DateTimeFormatUtils (fixupTzIn, fixupTzOut, fixupMs)
import Composite.Aeson.Formats.Provided (stringJsonFormat)
import Control.Monad.Error.Class (throwError)
import qualified Data.Aeson.BetterErrors as ABE
import Data.Either (partitionEithers)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NEL
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (FormatTime, ParseTime, TimeLocale, defaultTimeLocale, formatTime, parseTimeM)
import Data.Time.LocalTime (TimeOfDay)
data DateTimeFormat = DateTimeFormat
{ DateTimeFormat -> String
dateTimeFormat :: String
, DateTimeFormat -> String
dateTimeFormatExample :: String
, DateTimeFormat -> String -> String
dateTimeFormatPreParse :: String -> String
, DateTimeFormat -> String -> String
dateTimeFormatPostFormat :: String -> String
}
regularDateTimeFormat :: String -> String -> DateTimeFormat
regularDateTimeFormat :: String -> String -> DateTimeFormat
regularDateTimeFormat String
format String
example = String
-> String
-> (String -> String)
-> (String -> String)
-> DateTimeFormat
DateTimeFormat String
format String
example String -> String
forall a. a -> a
id String -> String
forall a. a -> a
id
dateTimeJsonFormat :: (ParseTime t, FormatTime t) => TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat :: TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
locale formats :: NonEmpty DateTimeFormat
formats@(DateTimeFormat
outFormat :| [DateTimeFormat]
otherInFormats) = JsonProfunctor e t t -> JsonFormat e t
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat ((t -> Value) -> Parse e t -> JsonProfunctor e t t
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor t -> Value
dayOut Parse e t
dayIn)
where
formatsList :: [DateTimeFormat]
formatsList = NonEmpty DateTimeFormat -> [DateTimeFormat]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty DateTimeFormat
formats
JsonFormat (JsonProfunctor String -> Value
stringOut Parse e String
stringIn) = JsonFormat e String
forall e. JsonFormat e String
stringJsonFormat
dayOut :: t -> Value
dayOut = String -> Value
stringOut (String -> Value) -> (t -> String) -> t -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateTimeFormat -> String -> String
dateTimeFormatPostFormat DateTimeFormat
outFormat (String -> String) -> (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
locale (DateTimeFormat -> String
dateTimeFormat DateTimeFormat
outFormat)
dayIn :: Parse e t
dayIn = do
String
s <- Parse e String
forall e. Parse e String
stringIn
let attempt :: DateTimeFormat -> Either String t
attempt DateTimeFormat
format = (String -> Either String t)
-> (t -> Either String t)
-> (forall (m :: * -> *). MonadFail m => m t)
-> Either String t
forall b a.
(String -> b)
-> (a -> b) -> (forall (m :: * -> *). MonadFail m => m a) -> b
successOrFail String -> Either String t
forall a b. a -> Either a b
Left t -> Either String t
forall a b. b -> Either a b
Right ((forall (m :: * -> *). MonadFail m => m t) -> Either String t)
-> (forall (m :: * -> *). MonadFail m => m t) -> Either String t
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> String -> m t
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
locale (DateTimeFormat -> String
dateTimeFormat DateTimeFormat
format) (DateTimeFormat -> String -> String
dateTimeFormatPreParse DateTimeFormat
format String
s)
attempts :: [Either String t]
attempts = (DateTimeFormat -> Either String t)
-> [DateTimeFormat] -> [Either String t]
forall a b. (a -> b) -> [a] -> [b]
map DateTimeFormat -> Either String t
attempt [DateTimeFormat]
formatsList
case [Either String t] -> ([String], [t])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String t]
attempts of
([String]
_, t
a : [t]
_) ->
t -> Parse e t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
a
([String]
es, [t]
_) | [DateTimeFormat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DateTimeFormat]
otherInFormats ->
String -> Parse e t
forall a. String -> ParseT e Identity a
toss (String -> Parse e t) -> String -> Parse e t
forall a b. (a -> b) -> a -> b
$ String
"expected date/time string formatted as " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DateTimeFormat -> String
dateTimeFormatExample DateTimeFormat
outFormat String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
es
([String]
es, [t]
_) ->
String -> Parse e t
forall a. String -> ParseT e Identity a
toss (String -> Parse e t) -> String -> Parse e t
forall a b. (a -> b) -> a -> b
$ String
"expected date/time string formatted as one of "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((DateTimeFormat -> String) -> [DateTimeFormat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DateTimeFormat -> String
dateTimeFormatExample [DateTimeFormat]
formatsList)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
es
toss :: String -> ParseT e Identity a
toss = ParseError e -> ParseT e Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> ParseT e Identity a)
-> (String -> ParseError e) -> String -> ParseT e Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathPiece] -> ErrorSpecifics e -> ParseError e
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] (ErrorSpecifics e -> ParseError e)
-> (String -> ErrorSpecifics e) -> String -> ParseError e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorSpecifics e
forall err. String -> ErrorSpecifics err
ABE.FromAeson
iso8601DateJsonFormat :: JsonFormat e Day
iso8601DateJsonFormat :: JsonFormat e Day
iso8601DateJsonFormat =
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e Day
forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
fmt DateTimeFormat -> [DateTimeFormat] -> NonEmpty DateTimeFormat
forall a. a -> [a] -> NonEmpty a
:| [])
where
fmt :: DateTimeFormat
fmt = String -> String -> DateTimeFormat
regularDateTimeFormat String
"%F" String
"yyyy-mm-dd"
iso8601DateTimeJsonFormat :: JsonFormat e UTCTime
iso8601DateTimeJsonFormat :: JsonFormat e UTCTime
iso8601DateTimeJsonFormat =
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e UTCTime
forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
withMs DateTimeFormat -> [DateTimeFormat] -> NonEmpty DateTimeFormat
forall a. a -> [a] -> NonEmpty a
:| [DateTimeFormat
withoutMs])
where
withMs :: DateTimeFormat
withMs = String
-> String
-> (String -> String)
-> (String -> String)
-> DateTimeFormat
DateTimeFormat String
"%FT%T%Q%z" String
"yyyy-mm-ddThh:mm:ss.sssZ" String -> String
fixupTzIn (String -> String
fixupTzOut (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fixupMs)
withoutMs :: DateTimeFormat
withoutMs = String
-> String
-> (String -> String)
-> (String -> String)
-> DateTimeFormat
DateTimeFormat String
"%FT%T%z" String
"yyyy-mm-ddThh:mm:ssZ" String -> String
fixupTzIn String -> String
fixupTzOut
iso8601TimeJsonFormat :: JsonFormat e TimeOfDay
iso8601TimeJsonFormat :: JsonFormat e TimeOfDay
iso8601TimeJsonFormat =
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e TimeOfDay
forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
withMs DateTimeFormat -> [DateTimeFormat] -> NonEmpty DateTimeFormat
forall a. a -> [a] -> NonEmpty a
:| [DateTimeFormat
withoutMs])
where
withMs :: DateTimeFormat
withMs = String
-> String
-> (String -> String)
-> (String -> String)
-> DateTimeFormat
DateTimeFormat String
"%T%Q%z" String
"hh:mm:ss.sss" String -> String
forall a. a -> a
id String -> String
fixupMs
withoutMs :: DateTimeFormat
withoutMs = String
-> String
-> (String -> String)
-> (String -> String)
-> DateTimeFormat
DateTimeFormat String
"%T%Q" String
"hh:mm:ss" String -> String
forall a. a -> a
id String -> String
forall a. a -> a
id
data SuccessOrFail a = Fail String | Success a
instance Functor SuccessOrFail where
fmap :: (a -> b) -> SuccessOrFail a -> SuccessOrFail b
fmap a -> b
f (Success a
a) = b -> SuccessOrFail b
forall a. a -> SuccessOrFail a
Success (a -> b
f a
a)
fmap a -> b
_ (Fail String
f) = String -> SuccessOrFail b
forall a. String -> SuccessOrFail a
Fail String
f
instance Applicative SuccessOrFail where
pure :: a -> SuccessOrFail a
pure = a -> SuccessOrFail a
forall a. a -> SuccessOrFail a
Success
Success a -> b
f <*> :: SuccessOrFail (a -> b) -> SuccessOrFail a -> SuccessOrFail b
<*> Success a
a = b -> SuccessOrFail b
forall a. a -> SuccessOrFail a
Success (a -> b
f a
a)
Success a -> b
_ <*> Fail String
f = String -> SuccessOrFail b
forall a. String -> SuccessOrFail a
Fail String
f
Fail String
f <*> SuccessOrFail a
_ = String -> SuccessOrFail b
forall a. String -> SuccessOrFail a
Fail String
f
instance Monad SuccessOrFail where
return :: a -> SuccessOrFail a
return = a -> SuccessOrFail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Success a
a >>= :: SuccessOrFail a -> (a -> SuccessOrFail b) -> SuccessOrFail b
>>= a -> SuccessOrFail b
k = a -> SuccessOrFail b
k a
a
Fail String
f >>= a -> SuccessOrFail b
_ = String -> SuccessOrFail b
forall a. String -> SuccessOrFail a
Fail String
f
#if MIN_VERSION_base(4,13,0)
instance MonadFail SuccessOrFail where
#endif
fail :: String -> SuccessOrFail a
fail = String -> SuccessOrFail a
forall a. String -> SuccessOrFail a
Fail
#if MIN_VERSION_base(4,13,0)
successOrFail :: (String -> b) -> (a -> b) -> (forall m. MonadFail m => m a) -> b
#else
successOrFail :: (String -> b) -> (a -> b) -> (forall m. Monad m => m a) -> b
#endif
successOrFail :: (String -> b)
-> (a -> b) -> (forall (m :: * -> *). MonadFail m => m a) -> b
successOrFail String -> b
_ a -> b
f (Success a) = a -> b
f a
a
successOrFail String -> b
f a -> b
_ (Fail s) = String -> b
f String
s
#if __GLASGOW_HASKELL__ >= 810
successOrFail String -> b
f a -> b
_ forall (m :: * -> *). MonadFail m => m a
_ = String -> b
f String
"pattern matching should have been exhaustive, but GHC disagreed"
#endif