-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
--
-- SPDX-License-Identifier: MPL-2.0

{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE CPP #-}

module Data.Time.TZTime.Internal where

import Control.Applicative (optional)
import Control.DeepSeq (NFData)
import Control.Exception.Safe (Exception(..), MonadThrow, throwM)
import Control.Monad.Except (MonadError, throwError)
import Data.Data (Data)
import Data.Fixed (Fixed(..), Pico)
import Data.Function ((&))
import Data.Functor (void, (<&>))
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty qualified as NE
import Data.Maybe (fromJust)
import Data.String (fromString)
import Data.Text qualified as T
import Data.Time (UTCTime, addUTCTime, secondsToNominalDiffTime)
import Data.Time qualified as Time
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Data.Time.Compat (pattern YearMonthDay)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Time.LocalTime
import Data.Time.TZInfo (TZIdentifier, TZInfo(..), fromIdentifier)
import Data.Time.Zones (LocalToUTCResult(..))
import Data.Time.Zones qualified as TZ
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadP qualified as P

import Language.Haskell.TH.Syntax (Q, liftTyped)
#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH.Syntax (Code, Quote)
#else
import Language.Haskell.TH.Syntax (TExp)
#endif

{-# ANN module ("HLint: ignore Use fewer imports" :: String) #-}

----------------------------------------------------------------------------
-- TZTime
----------------------------------------------------------------------------

-- | A valid and unambiguous point in time in some time zone.
data TZTime = UnsafeTZTime
  { TZTime -> LocalTime
tztLocalTime :: LocalTime
  , TZTime -> TZInfo
tztTZInfo :: TZInfo
  , TZTime -> TimeZone
tztOffset :: Time.TimeZone
  }
  deriving stock (TZTime -> TZTime -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TZTime -> TZTime -> Bool
$c/= :: TZTime -> TZTime -> Bool
== :: TZTime -> TZTime -> Bool
$c== :: TZTime -> TZTime -> Bool
Eq, Typeable TZTime
TZTime -> DataType
TZTime -> Constr
(forall b. Data b => b -> b) -> TZTime -> TZTime
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> TZTime -> u
forall u. (forall d. Data d => d -> u) -> TZTime -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZTime
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZTime -> c TZTime
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZTime)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZTime)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZTime -> m TZTime
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> TZTime -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> TZTime -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> TZTime -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> TZTime -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> TZTime -> r
gmapT :: (forall b. Data b => b -> b) -> TZTime -> TZTime
$cgmapT :: (forall b. Data b => b -> b) -> TZTime -> TZTime
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZTime)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZTime)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZTime)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZTime)
dataTypeOf :: TZTime -> DataType
$cdataTypeOf :: TZTime -> DataType
toConstr :: TZTime -> Constr
$ctoConstr :: TZTime -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZTime
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZTime
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZTime -> c TZTime
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZTime -> c TZTime
Data, forall x. Rep TZTime x -> TZTime
forall x. TZTime -> Rep TZTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TZTime x -> TZTime
$cfrom :: forall x. TZTime -> Rep TZTime x
Generic)
  deriving anyclass TZTime -> ()
forall a. (a -> ()) -> NFData a
rnf :: TZTime -> ()
$crnf :: TZTime -> ()
NFData

{- |
@yyyy-mm-dd hh:mm:ss[.sss] ±hh:mm [time zone]@.
Example: @2022-03-04 02:02:01 +01:00 [Europe/Rome]@.
-}
instance Show TZTime where
  show :: TZTime -> String
show (UnsafeTZTime LocalTime
lt TZInfo
tzi TimeZone
offset) =
    forall a. Show a => a -> String
show LocalTime
lt forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall t. ISO8601 t => t -> String
iso8601Show TimeZone
offset forall a. Semigroup a => a -> a -> a
<> String
" [" forall a. Semigroup a => a -> a -> a
<> String
tzIdent forall a. Semigroup a => a -> a -> a
<> String
"]"
    where
      tzIdent :: String
tzIdent = TZIdentifier -> String
T.unpack forall a b. (a -> b) -> a -> b
$ TZInfo -> TZIdentifier
tziIdentifier TZInfo
tzi

-- | The local time of this `TZTime`.
tzTimeLocalTime :: TZTime -> LocalTime
tzTimeLocalTime :: TZTime -> LocalTime
tzTimeLocalTime = TZTime -> LocalTime
tztLocalTime

-- | The time zone of this `TZTime`.
tzTimeTZInfo :: TZTime -> TZInfo
tzTimeTZInfo :: TZTime -> TZInfo
tzTimeTZInfo = TZTime -> TZInfo
tztTZInfo

-- | The offset observed in this time zone at this moment in time.
tzTimeOffset :: TZTime -> TimeZone
tzTimeOffset :: TZTime -> TimeZone
tzTimeOffset = TZTime -> TimeZone
tztOffset

----------------------------------------------------------------------------
-- Constructors
----------------------------------------------------------------------------

-- | Converts a `UTCTime` to the given time zone.
fromUTC :: TZInfo -> UTCTime -> TZTime
fromUTC :: TZInfo -> UTCTime -> TZTime
fromUTC TZInfo
tzi UTCTime
utct =
  UnsafeTZTime
    { tztLocalTime :: LocalTime
tztLocalTime = TZ -> UTCTime -> LocalTime
TZ.utcToLocalTimeTZ (TZInfo -> TZ
tziRules TZInfo
tzi) UTCTime
utct
    , tztTZInfo :: TZInfo
tztTZInfo = TZInfo
tzi
    , tztOffset :: TimeZone
tztOffset = TZ -> UTCTime -> TimeZone
TZ.timeZoneForUTCTime (TZInfo -> TZ
tziRules TZInfo
tzi) UTCTime
utct
    }

-- | Converts a `POSIXTime` to the given time zone.
fromPOSIXTime :: TZInfo -> POSIXTime -> TZTime
fromPOSIXTime :: TZInfo -> POSIXTime -> TZTime
fromPOSIXTime TZInfo
tzi = TZInfo -> UTCTime -> TZTime
fromUTC TZInfo
tzi forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> UTCTime
posixSecondsToUTCTime

-- | Converts a `ZonedTime` to UTC and then to the given time zone.
fromZonedTime :: TZInfo -> ZonedTime -> TZTime
fromZonedTime :: TZInfo -> ZonedTime -> TZTime
fromZonedTime TZInfo
tzi = TZInfo -> UTCTime -> TZTime
fromUTC TZInfo
tzi forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> UTCTime
zonedTimeToUTC

-- | Attempted to construct a `TZTime` from an invalid or ambiguous `LocalTime`.
data TZError
  = TZOverlap
      LocalTime
      -- ^ The `LocalTime` is ambiguous.
      -- This usually happens when the clocks are set back in
      -- autumn and a local time happens twice.
      ~TZTime -- ^ The first occurrence of the given `LocalTime`, at the earliest offset.
      ~TZTime -- ^ The second occurrence of the given `LocalTime`, at the latest offset.
  | TZGap
      LocalTime
      -- ^ The `LocalTime` is invalid.
      -- This usually happens when the clocks are set forward in
      -- spring and a local time is skipped.
      ~TZTime -- ^ The given `LocalTime` adjusted back by the length of the gap.
      ~TZTime -- ^ The given `LocalTime` adjusted forward by the length of the gap.
  deriving stock (TZError -> TZError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TZError -> TZError -> Bool
$c/= :: TZError -> TZError -> Bool
== :: TZError -> TZError -> Bool
$c== :: TZError -> TZError -> Bool
Eq, Typeable TZError
TZError -> DataType
TZError -> Constr
(forall b. Data b => b -> b) -> TZError -> TZError
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> TZError -> u
forall u. (forall d. Data d => d -> u) -> TZError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZError -> c TZError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZError)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> TZError -> m TZError
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> TZError -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> TZError -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> TZError -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> TZError -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TZError -> r
gmapT :: (forall b. Data b => b -> b) -> TZError -> TZError
$cgmapT :: (forall b. Data b => b -> b) -> TZError -> TZError
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c TZError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZError)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TZError)
dataTypeOf :: TZError -> DataType
$cdataTypeOf :: TZError -> DataType
toConstr :: TZError -> Constr
$ctoConstr :: TZError -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TZError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZError -> c TZError
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> TZError -> c TZError
Data, forall x. Rep TZError x -> TZError
forall x. TZError -> Rep TZError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TZError x -> TZError
$cfrom :: forall x. TZError -> Rep TZError x
Generic)
  deriving anyclass (TZError -> ()
forall a. (a -> ()) -> NFData a
rnf :: TZError -> ()
$crnf :: TZError -> ()
NFData)

instance Show TZError where
  show :: TZError -> String
show = forall e. Exception e => e -> String
displayException

instance Exception TZError where
  displayException :: TZError -> String
displayException = \case
    TZGap LocalTime
lt TZTime
tzt1 TZTime
_ ->
      String
"The local time "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show LocalTime
lt
      forall a. Semigroup a => a -> a -> a
<> String
" is invalid in the time zone "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (TZInfo -> TZIdentifier
tziIdentifier forall a b. (a -> b) -> a -> b
$ TZTime -> TZInfo
tztTZInfo TZTime
tzt1)
      forall a. Semigroup a => a -> a -> a
<> String
"."
    TZOverlap LocalTime
lt TZTime
tzt1 TZTime
tzt2 ->
      String
"The local time "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show LocalTime
lt
      forall a. Semigroup a => a -> a -> a
<> String
" is ambiguous in the time zone "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (TZInfo -> TZIdentifier
tziIdentifier forall a b. (a -> b) -> a -> b
$ TZTime -> TZInfo
tztTZInfo TZTime
tzt1)
      forall a. Semigroup a => a -> a -> a
<> String
": it is observed at the offsets "
      forall a. Semigroup a => a -> a -> a
<> forall t. ISO8601 t => t -> String
iso8601Show (TZTime -> TimeZone
tzTimeOffset TZTime
tzt1)
      forall a. Semigroup a => a -> a -> a
<> String
" and "
      forall a. Semigroup a => a -> a -> a
<> forall t. ISO8601 t => t -> String
iso8601Show (TZTime -> TimeZone
tzTimeOffset TZTime
tzt2)
      forall a. Semigroup a => a -> a -> a
<> String
"."

-- | Similar to `fromLocalTime`, but returns a `TZError`
-- if the local time is ambiguous/invalid.
fromLocalTimeStrict :: MonadError TZError m => TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict :: forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict TZInfo
tzi LocalTime
lt =
  case TZ -> LocalTime -> LocalToUTCResult
TZ.localTimeToUTCFull (TZInfo -> TZ
tziRules TZInfo
tzi) LocalTime
lt of
    LTUUnique UTCTime
_utc TimeZone
namedOffset ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalTime -> TZInfo -> TimeZone -> TZTime
UnsafeTZTime LocalTime
lt TZInfo
tzi TimeZone
namedOffset
    LTUAmbiguous UTCTime
_utc1 UTCTime
_utc2 TimeZone
namedOffset1 TimeZone
namedOffset2 ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ LocalTime -> TZTime -> TZTime -> TZError
TZOverlap LocalTime
lt
        (LocalTime -> TZInfo -> TimeZone -> TZTime
UnsafeTZTime LocalTime
lt TZInfo
tzi TimeZone
namedOffset1)
        (LocalTime -> TZInfo -> TimeZone -> TZTime
UnsafeTZTime LocalTime
lt TZInfo
tzi TimeZone
namedOffset2)
    -- Note: LTUNone means the given `LocalTime` is invalid and lands on a "gap".
    -- The constructor contains:
    -- 1. The `UTCTime` corresponding to the `LocalTime` shifted forward by the duration of the gap.
    --    E.g., if it's a 1-hour gap, this will be the same as "toUTC (localTime + 1 hour)"
    -- 2. The offset observed in that time zone before the clocks changed.
    --
    -- From these 2 pieces of information, we can figure out the rest.
    --
    -- This approach works but is inefficient.
    -- TODO: reimplement parts of `localTimeToUTCFull` to make this more efficient.
    LTUNone UTCTime
utcAfter TimeZone
offsetBefore ->
      let
        offsetAfter :: TimeZone
offsetAfter = TZ -> UTCTime -> TimeZone
TZ.timeZoneForUTCTime (TZInfo -> TZ
tziRules TZInfo
tzi) UTCTime
utcAfter
        gap :: POSIXTime
gap = Pico -> POSIXTime
secondsToNominalDiffTime forall a b. (a -> b) -> a -> b
$ Pico
60 forall a. Num a => a -> a -> a
*
          forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Pico (TimeZone -> Int
timeZoneMinutes TimeZone
offsetAfter forall a. Num a => a -> a -> a
- TimeZone -> Int
timeZoneMinutes TimeZone
offsetBefore)
        utcBefore :: UTCTime
utcBefore = POSIXTime -> UTCTime -> UTCTime
addUTCTime (- POSIXTime
gap) UTCTime
utcAfter
      in
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ LocalTime -> TZTime -> TZTime -> TZError
TZGap LocalTime
lt
          (LocalTime -> TZInfo -> TimeZone -> TZTime
UnsafeTZTime (TZ -> UTCTime -> LocalTime
TZ.utcToLocalTimeTZ (TZInfo -> TZ
tziRules TZInfo
tzi) UTCTime
utcBefore) TZInfo
tzi TimeZone
offsetBefore)
          (LocalTime -> TZInfo -> TimeZone -> TZTime
UnsafeTZTime (TZ -> UTCTime -> LocalTime
TZ.utcToLocalTimeTZ (TZInfo -> TZ
tziRules TZInfo
tzi) UTCTime
utcAfter) TZInfo
tzi TimeZone
offsetAfter)

-- | Constructs a `TZTime` from a local time in the given time zone.
--
-- * If the local time lands on a "gap" (e.g. when the clocks are set forward in spring and a local time is skipped),
--   we shift the time forward by the duration of the gap.
-- * If it lands on an "overlap" (e.g. when the clocks are set back in autumn and a local time happens twice),
--   we use the earliest offset.
fromLocalTime :: TZInfo -> LocalTime -> TZTime
fromLocalTime :: TZInfo -> LocalTime -> TZTime
fromLocalTime TZInfo
tzi LocalTime
lt =
  case forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict TZInfo
tzi LocalTime
lt of
    Right TZTime
tzt -> TZTime
tzt
    Left (TZGap LocalTime
_ TZTime
_ TZTime
after) -> TZTime
after
    Left (TZOverlap LocalTime
_ TZTime
atEarliestOffset TZTime
_) -> TZTime
atEarliestOffset

-- | Similar to `fromLocalTime`, but throws a `TZError` in `MonadThrow`
-- if the local time is ambiguous/invalid.
fromLocalTimeThrow :: MonadThrow m => TZInfo -> LocalTime -> m TZTime
fromLocalTimeThrow :: forall (m :: * -> *).
MonadThrow m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeThrow TZInfo
tzi =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict TZInfo
tzi

-- | Similar to `fromLocalTime`, but throws an `error`
-- if the local time is ambiguous/invalid.
unsafeFromLocalTime :: HasCallStack => TZInfo -> LocalTime -> TZTime
unsafeFromLocalTime :: HasCallStack => TZInfo -> LocalTime -> TZTime
unsafeFromLocalTime TZInfo
tzi LocalTime
lt =
  case forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict TZInfo
tzi LocalTime
lt of
    Right TZTime
tzt -> TZTime
tzt
    Left TZError
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unsafeFromLocalTime: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException TZError
err

----------------------------------------------------------------------------
-- Conversions
----------------------------------------------------------------------------

-- | Converts this moment in time to the universal time-line.
toUTC :: TZTime -> UTCTime
toUTC :: TZTime -> UTCTime
toUTC TZTime
tzt =
  TimeZone -> LocalTime -> UTCTime
localTimeToUTC (TZTime -> TimeZone
tzTimeOffset TZTime
tzt) (TZTime -> LocalTime
tzTimeLocalTime TZTime
tzt)

-- | Converts this moment in time to a POSIX timestamp.
toPOSIXTime :: TZTime -> POSIXTime
toPOSIXTime :: TZTime -> POSIXTime
toPOSIXTime = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. TZTime -> UTCTime
toUTC

-- | Converts this moment in time to a `ZonedTime` (discarding time zone rules).
toZonedTime :: TZTime -> ZonedTime
toZonedTime :: TZTime -> ZonedTime
toZonedTime TZTime
tzt = LocalTime -> TimeZone -> ZonedTime
ZonedTime (TZTime -> LocalTime
tzTimeLocalTime TZTime
tzt) (TZTime -> TimeZone
tzTimeOffset TZTime
tzt)

-- | Converts this moment in time to some other time zone.
inTZ :: TZInfo -> TZTime -> TZTime
inTZ :: TZInfo -> TZTime -> TZTime
inTZ TZInfo
tzi = TZInfo -> UTCTime -> TZTime
fromUTC TZInfo
tzi forall b c a. (b -> c) -> (a -> b) -> a -> c
. TZTime -> UTCTime
toUTC

----------------------------------------------------------------------------
-- Modifying a TZTime
----------------------------------------------------------------------------

-- | Modify this moment in time along the universal time-line.
modifyUniversalTimeLine :: (UTCTime -> UTCTime) -> TZTime -> TZTime
modifyUniversalTimeLine :: (UTCTime -> UTCTime) -> TZTime -> TZTime
modifyUniversalTimeLine UTCTime -> UTCTime
f TZTime
tzt =
  TZInfo -> UTCTime -> TZTime
fromUTC (TZTime -> TZInfo
tzTimeTZInfo TZTime
tzt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. TZTime -> UTCTime
toUTC forall a b. (a -> b) -> a -> b
$ TZTime
tzt

-- | Modify this moment in time along the local time-line.
modifyLocalTimeLine :: MonadError TZError m => (LocalTime -> LocalTime) -> TZTime -> m TZTime
modifyLocalTimeLine :: forall (m :: * -> *).
MonadError TZError m =>
(LocalTime -> LocalTime) -> TZTime -> m TZTime
modifyLocalTimeLine LocalTime -> LocalTime
f TZTime
tzt =
  forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict (TZTime -> TZInfo
tzTimeTZInfo TZTime
tzt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> LocalTime
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. TZTime -> LocalTime
tzTimeLocalTime forall a b. (a -> b) -> a -> b
$ TZTime
tzt

----------------------------------------------------------------------------
-- Parsing
----------------------------------------------------------------------------

{- |
@yyyy-mm-dd hh:mm:ss[.sss] [±hh:mm] [time zone]@.
Example: @2022-03-04 02:02:01 +01:00 [Europe/Rome]@.

The offset is optional, except when the local time is ambiguous
(i.e. when the clocks are set forward around that time in that time zone).

The offset can also be expressed using [military time zone abbreviations](https://www.timeanddate.com/time/zones/military),
and these time zones abbreviations as per RFC 822 section 5:
\"UTC\", \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\".

Note: the time zone's rules are loaded from the embedded database using `fromIdentifier`.
-}
instance Read TZTime where
  readsPrec :: Int -> ReadS TZTime
readsPrec Int
_ String
input = do
    ((LocalTime
lt, Maybe TimeZone
offsetMaybe, TZIdentifier
ident), String
input) <- forall a. ReadP a -> ReadS a
P.readP_to_S ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
readComponentsP String
input
    case forall (m :: * -> *).
MonadFail m =>
LocalTime -> TZIdentifier -> m (NonEmpty TZTime)
getValidTZTimes LocalTime
lt TZIdentifier
ident forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadFail m =>
Maybe TimeZone -> NonEmpty TZTime -> m (NonEmpty TZTime)
checkOffset Maybe TimeZone
offsetMaybe of
      Maybe (NonEmpty TZTime)
Nothing -> []
      Just (TZTime
tzt :| []) -> [(TZTime
tzt, String
input)]
      Just (NonEmpty TZTime
tzts) -> forall a. NonEmpty a -> [a]
NE.toList NonEmpty TZTime
tzts forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TZTime
tzt -> (TZTime
tzt, String
input)

readComponentsP :: ReadP (LocalTime, Maybe Time.TimeZone, TZIdentifier)
readComponentsP :: ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
readComponentsP =
  (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. ReadS a -> ReadP a
P.readS_to_P forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadS a
reads @LocalTime)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall a. ReadS a -> ReadP a
P.readS_to_P forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadS a
reads @Time.TimeZone)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP TZIdentifier
readTZIdentP

readTZIdentP :: ReadP TZIdentifier
readTZIdentP :: ReadP TZIdentifier
readTZIdentP = do
  ReadP ()
P.skipSpaces
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'['
  forall a. IsString a => String -> a
fromString @TZIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a end. ReadP a -> ReadP end -> ReadP [a]
P.manyTill ReadP Char
P.get (Char -> ReadP Char
P.char Char
']')

-- | Try to construct a `TZTime` from the given components.
getValidTZTimes :: MonadFail m => LocalTime -> TZIdentifier -> m (NonEmpty TZTime)
getValidTZTimes :: forall (m :: * -> *).
MonadFail m =>
LocalTime -> TZIdentifier -> m (NonEmpty TZTime)
getValidTZTimes LocalTime
lt TZIdentifier
ident = do
  TZInfo
tzi <- case TZIdentifier -> Maybe TZInfo
fromIdentifier TZIdentifier
ident of
    Maybe TZInfo
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown time zone: '" forall a. Semigroup a => a -> a -> a
<> TZIdentifier -> String
T.unpack TZIdentifier
ident forall a. Semigroup a => a -> a -> a
<> String
"'"
    Just TZInfo
tzi -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TZInfo
tzi
  case forall (m :: * -> *).
MonadError TZError m =>
TZInfo -> LocalTime -> m TZTime
fromLocalTimeStrict TZInfo
tzi LocalTime
lt of
    Right TZTime
tzt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TZTime
tzt forall a. a -> [a] -> NonEmpty a
:| []
    Left (TZOverlap LocalTime
_ TZTime
tzt1 TZTime
tzt2) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TZTime
tzt1 forall a. a -> [a] -> NonEmpty a
:| [TZTime
tzt2]
    Left (TZGap LocalTime
_ TZTime
tzt1 TZTime
tzt2) ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid time: the clocks are set forward around this time.\n" forall a. Semigroup a => a -> a -> a
<> NonEmpty TZTime -> String
mkSuggestions (TZTime
tzt1 forall a. a -> [a] -> NonEmpty a
:| [TZTime
tzt2])

-- | If the user specified an offset, check that it matches at least one of the valid `TZTime`s.
checkOffset :: MonadFail m => Maybe Time.TimeZone -> NonEmpty TZTime -> m (NonEmpty TZTime)
checkOffset :: forall (m :: * -> *).
MonadFail m =>
Maybe TimeZone -> NonEmpty TZTime -> m (NonEmpty TZTime)
checkOffset Maybe TimeZone
offsetMaybe NonEmpty TZTime
tzts =
  case Maybe TimeZone
offsetMaybe of
    Maybe TimeZone
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty TZTime
tzts
    Just TimeZone
offset ->
      NonEmpty TZTime
tzts
        forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (\TZTime
tzt -> TimeZone -> Int
timeZoneMinutes TimeZone
offset forall a. Eq a => a -> a -> Bool
== TimeZone -> Int
timeZoneMinutes (TZTime -> TimeZone
tzTimeOffset TZTime
tzt))
        forall a b. a -> (a -> b) -> b
& forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
        forall a b. a -> (a -> b) -> b
& \case
            Just NonEmpty TZTime
validTzts -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty TZTime
validTzts
            Maybe (NonEmpty TZTime)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid offset: " forall a. Semigroup a => a -> a -> a
<> forall t. ISO8601 t => t -> String
iso8601Show TimeZone
offset forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> NonEmpty TZTime -> String
mkSuggestions NonEmpty TZTime
tzts

mkSuggestions :: NonEmpty TZTime -> String
mkSuggestions :: NonEmpty TZTime -> String
mkSuggestions NonEmpty TZTime
tzts =
  String
"      Did you mean any of the following?" forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\TZTime
tzt -> String
"\n      - " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TZTime
tzt) NonEmpty TZTime
tzts

----------------------------------------------------------------------------
-- Template Haskell
----------------------------------------------------------------------------

readP_to_Q :: String -> ReadP a -> Q a
readP_to_Q :: forall a. String -> ReadP a -> Q a
readP_to_Q String
input ReadP a
parser =
  case forall a. ReadP a -> ReadS a
P.readP_to_S (ReadP a
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
P.eof) String
input of
    [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to parse: '" forall a. Semigroup a => a -> a -> a
<> String
input forall a. Semigroup a => a -> a -> a
<> String
"'"
    [(a
res, String
_)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
    [(a, String)]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parsing is ambiguous: '" forall a. Semigroup a => a -> a -> a
<> String
input forall a. Semigroup a => a -> a -> a
<> String
"'"

#if MIN_VERSION_template_haskell(2,17,0)
liftTZTime :: Quote m => TZTime -> Code m TZTime
liftLocalTime :: Quote m => LocalTime -> Code m LocalTime
liftTimeZone :: Quote m => Time.TimeZone -> Code m Time.TimeZone
#else
liftTZTime :: TZTime -> Q (TExp TZTime)
liftTimeZone :: Time.TimeZone -> Q (TExp Time.TimeZone)
liftLocalTime :: LocalTime -> Q (TExp LocalTime)
#endif

-- | NOTE: this assumes the time zone identifier used to construct `TZTime` exists in the
-- embedded time zone database, i.e. it can be loaded using `fromIdentifier`.
liftTZTime :: forall (m :: * -> *). Quote m => TZTime -> Code m TZTime
liftTZTime TZTime
tzt =
  [e||
    UnsafeTZTime
      $$(liftLocalTime $ tzTimeLocalTime tzt)
      (fromJust $ fromIdentifier $$(liftTyped ident))
      $$(liftTimeZone $ tzTimeOffset tzt)
  ||]
  where
    ident :: TZIdentifier
ident = TZInfo -> TZIdentifier
tziIdentifier forall a b. (a -> b) -> a -> b
$ TZTime -> TZInfo
tzTimeTZInfo TZTime
tzt

liftLocalTime :: forall (m :: * -> *). Quote m => LocalTime -> Code m LocalTime
liftLocalTime (LocalTime (YearMonthDay Year
yy Int
mm Int
dd) (TimeOfDay Int
hh Int
mmm (MkFixed Year
ss))) =
  [e||
    LocalTime
      (YearMonthDay $$(liftTyped yy) $$(liftTyped mm) $$(liftTyped dd))
      (TimeOfDay $$(liftTyped hh) $$(liftTyped mmm) (MkFixed $$(liftTyped ss)))
  ||]

liftTimeZone :: forall (m :: * -> *). Quote m => TimeZone -> Code m TimeZone
liftTimeZone (TimeZone Int
tzMins Bool
tzSummer String
tzName) =
  [e|| TimeZone $$(liftTyped tzMins) $$(liftTyped tzSummer) $$(liftTyped tzName) ||]