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

{-# LANGUAGE CPP #-}

module Data.Time.TZTime.QQ
  ( tz
  ) where

import Data.List.NonEmpty (NonEmpty(..))
import Data.Time.TZTime.Internal as I
import Language.Haskell.TH (Exp, Q)
import Language.Haskell.TH.Quote
import Text.ParserCombinators.ReadP qualified as P

#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH.Syntax (unTypeCode)
#else
import Language.Haskell.TH.Syntax (unType)
#endif

{- |
Quasiquoter for parsing a `TZTime` at compile-time in the format:
@yyyy-mm-dd hh:mm:ss[.sss] [±hh:mm] [time zone]@.

The offset is optional, except when the local time is ambiguous
(i.e. when the clocks are set back 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 `Data.Time.TZInfo.fromIdentifier`.

>>> [tz|2022-03-04 10:15:40.123 [Europe/Rome]|]
2022-03-04 10:15:40.123 +01:00 [Europe/Rome]

>>> [tz|2022-11-06 01:30:00 [America/Winnipeg]|]
...
    • Ambiguous time: please specify an offset.
      Did you mean any of the following?
      - 2022-11-06 01:30:00 -05:00 [America/Winnipeg]
      - 2022-11-06 01:30:00 -06:00 [America/Winnipeg]
...

-}
tz :: QuasiQuoter
tz :: QuasiQuoter
tz = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
qexp
  , quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'tz' as a pattern."
  , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'tz' as a type."
  , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ ->String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot use 'tz' as a declaration."
  }
  where
    qexp :: String -> Q Exp
    qexp :: String -> Q Exp
qexp String
input = do
      (LocalTime
lt, Maybe TimeZone
offsetMaybe, TZIdentifier
ident) <- String
-> ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
-> Q (LocalTime, Maybe TimeZone, TZIdentifier)
forall a. String -> ReadP a -> Q a
I.readP_to_Q String
input (ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
I.readComponentsP ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
-> ReadP () -> ReadP (LocalTime, Maybe TimeZone, TZIdentifier)
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
P.skipSpaces)
      LocalTime -> TZIdentifier -> Q (NonEmpty TZTime)
forall (m :: * -> *).
MonadFail m =>
LocalTime -> TZIdentifier -> m (NonEmpty TZTime)
I.getValidTZTimes LocalTime
lt TZIdentifier
ident Q (NonEmpty TZTime)
-> (NonEmpty TZTime -> Q (NonEmpty TZTime)) -> Q (NonEmpty TZTime)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeZone -> NonEmpty TZTime -> Q (NonEmpty TZTime)
forall (m :: * -> *).
MonadFail m =>
Maybe TimeZone -> NonEmpty TZTime -> m (NonEmpty TZTime)
I.checkOffset Maybe TimeZone
offsetMaybe Q (NonEmpty TZTime) -> (NonEmpty TZTime -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TZTime
tzt :| [] -> TZTime -> Q Exp
toExp TZTime
tzt
        NonEmpty TZTime
tzts -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous time: please specify an offset.\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty TZTime -> String
I.mkSuggestions NonEmpty TZTime
tzts

    toExp :: TZTime -> Q Exp
    toExp :: TZTime -> Q Exp
toExp TZTime
tzt =
#if MIN_VERSION_template_haskell(2,17,0)
      Code Q TZTime -> Q Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code Q TZTime -> Q Exp) -> Code Q TZTime -> Q Exp
forall a b. (a -> b) -> a -> b
$ TZTime -> Code Q TZTime
forall (m :: * -> *). Quote m => TZTime -> Code m TZTime
I.liftTZTime TZTime
tzt
#else
      unType <$> I.liftTZTime tzt
#endif