{-# 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)

-- |Structure carrying the date/time format string along with an example for error messaging and functions which optionally permute the input or output
-- before using the format.
data DateTimeFormat = DateTimeFormat
  { DateTimeFormat -> String
dateTimeFormat           :: String
  , DateTimeFormat -> String
dateTimeFormatExample    :: String
  , DateTimeFormat -> String -> String
dateTimeFormatPreParse   :: String -> String
  , DateTimeFormat -> String -> String
dateTimeFormatPostFormat :: String -> String
  }

-- |Construct a 'DateTimeFormat' with no pre- or post- processing.
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 forall a. a -> a
id forall a. a -> a
id

-- |'JsonFormat' for any type which 'ParseTime' and 'FormatTime' are defined for which maps to JSON via the first format given and maps from JSON via
-- any format given.
dateTimeJsonFormat :: (ParseTime t, FormatTime t) => TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat :: forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
locale formats :: NonEmpty DateTimeFormat
formats@(DateTimeFormat
outFormat :| [DateTimeFormat]
otherInFormats) = forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat (forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor t -> Value
dayOut ParseT e Identity t
dayIn)
  where
    formatsList :: [DateTimeFormat]
formatsList = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty DateTimeFormat
formats
    JsonFormat (JsonProfunctor String -> Value
stringOut Parse e String
stringIn) = forall e. JsonFormat e String
stringJsonFormat
    dayOut :: t -> Value
dayOut = String -> Value
stringOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateTimeFormat -> String -> String
dateTimeFormatPostFormat DateTimeFormat
outFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
locale (DateTimeFormat -> String
dateTimeFormat DateTimeFormat
outFormat)
    dayIn :: ParseT e Identity t
dayIn = do
      String
s <- forall {e}. Parse e String
stringIn
      let attempt :: DateTimeFormat -> Either String t
attempt DateTimeFormat
format = forall b a.
(String -> b)
-> (a -> b) -> (forall (m :: * -> *). MonadFail m => m a) -> b
successOrFail forall a b. a -> Either a b
Left forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map DateTimeFormat -> Either String t
attempt [DateTimeFormat]
formatsList
      case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String t]
attempts of
        ([String]
_, t
a : [t]
_) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure t
a
        ([String]
es, [t]
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DateTimeFormat]
otherInFormats ->
          forall {a}. String -> ParseT e Identity a
toss forall a b. (a -> b) -> a -> b
$ String
"expected date/time string formatted as " forall a. Semigroup a => a -> a -> a
<> DateTimeFormat -> String
dateTimeFormatExample DateTimeFormat
outFormat forall a. Semigroup a => a -> a -> a
<> String
", but: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
es
        ([String]
es, [t]
_) ->
          forall {a}. String -> ParseT e Identity a
toss forall a b. (a -> b) -> a -> b
$ String
"expected date/time string formatted as one of "
              forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map DateTimeFormat -> String
dateTimeFormatExample [DateTimeFormat]
formatsList)
              forall a. Semigroup a => a -> a -> a
<> String
", but: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
es
    toss :: String -> ParseT e Identity a
toss = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. String -> ErrorSpecifics err
ABE.FromAeson

-- |ISO8601 extended date format (@yyyy-mm-dd@).
iso8601DateJsonFormat :: JsonFormat e Day
iso8601DateJsonFormat :: forall e. JsonFormat e Day
iso8601DateJsonFormat =
  forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
fmt forall a. a -> [a] -> NonEmpty a
:| [])
  where
    fmt :: DateTimeFormat
fmt = String -> String -> DateTimeFormat
regularDateTimeFormat String
"%F" String
"yyyy-mm-dd"

-- |ISO8601 extended date/time format (@yyyy-mm-ddThh:mm:ss.sssZ@ or @yyyy-mm-ttThh:mm:ssZ@)
iso8601DateTimeJsonFormat :: JsonFormat e UTCTime
iso8601DateTimeJsonFormat :: forall e. JsonFormat e UTCTime
iso8601DateTimeJsonFormat =
  forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
withMs 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 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

-- |ISO8601 extended time format (@hh:mm:ss.sss@ or @hh:mm:ss@)
iso8601TimeJsonFormat :: JsonFormat e TimeOfDay
iso8601TimeJsonFormat :: forall e. JsonFormat e TimeOfDay
iso8601TimeJsonFormat =
  forall t e.
(ParseTime t, FormatTime t) =>
TimeLocale -> NonEmpty DateTimeFormat -> JsonFormat e t
dateTimeJsonFormat TimeLocale
defaultTimeLocale (DateTimeFormat
withMs 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" 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"     forall a. a -> a
id forall a. a -> a
id


-- |Monad for capturing uses of 'fail', because @Data.Time.Format@ has a poorly factored interface.
data SuccessOrFail a = Fail String | Success a

instance Functor SuccessOrFail where
  fmap :: forall a b. (a -> b) -> SuccessOrFail a -> SuccessOrFail b
fmap a -> b
f (Success a
a) = forall a. a -> SuccessOrFail a
Success (a -> b
f a
a)
  fmap a -> b
_ (Fail    String
f) = forall a. String -> SuccessOrFail a
Fail    String
f

instance Applicative SuccessOrFail where
  pure :: forall a. a -> SuccessOrFail a
pure   = forall a. a -> SuccessOrFail a
Success
  Success a -> b
f <*> :: forall a b.
SuccessOrFail (a -> b) -> SuccessOrFail a -> SuccessOrFail b
<*> Success a
a = forall a. a -> SuccessOrFail a
Success (a -> b
f a
a)
  Success a -> b
_ <*> Fail    String
f = forall a. String -> SuccessOrFail a
Fail    String
f
  Fail    String
f <*> SuccessOrFail a
_         = forall a. String -> SuccessOrFail a
Fail    String
f

instance Monad SuccessOrFail where
  return :: forall a. a -> SuccessOrFail a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Success a
a >>= :: forall a b.
SuccessOrFail a -> (a -> SuccessOrFail b) -> SuccessOrFail b
>>= a -> SuccessOrFail b
k = a -> SuccessOrFail b
k a
a
  Fail    String
f >>= a -> SuccessOrFail b
_ = forall a. String -> SuccessOrFail a
Fail String
f
#if MIN_VERSION_base(4,13,0)
instance MonadFail SuccessOrFail where
#endif
  fail :: forall a. String -> SuccessOrFail a
fail   = forall a. String -> SuccessOrFail a
Fail

-- |Evaluate some action of type @Monad m => m a@ and apply either the first or second function based on whether the computation completed or used @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 :: forall b a.
(String -> b)
-> (a -> b) -> (forall (m :: * -> *). MonadFail m => m a) -> b
successOrFail String -> b
_ a -> b
f (Success a
a) = a -> b
f a
a
successOrFail String -> b
f a -> b
_ (Fail    String
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