{-|
Module:      Z.Data.Parser.Time
Description : Parsers for types from time.
Copyright:   (c) 2015-2016 Bryan O'Sullivan
             (c) 2020 Dong Han
License:     BSD3
Maintainer:  Dong <winterland1989@gmail.com>
Stability:   experimental
Portability: portable

Parsers for parsing dates and times.
-}

module Z.Data.Parser.Time
    ( day
    , localTime
    , timeOfDay
    , timeZone
    , utcTime
    , zonedTime
    -- * internal
    , fromGregorianValid'
    , fromGregorianValidInt64
    ) where

import           Control.Applicative   ((<|>))
import           Data.Fixed            (Fixed (..), Pico)
import           Data.Int              (Int64)
import           Data.Maybe            (fromMaybe)
import           Data.Time.Calendar    (Day(..), fromGregorianValid)
import           Data.Time.Clock       (UTCTime (..))
import           Data.Time.LocalTime   hiding (utc)
import           Z.Data.ASCII
import qualified Z.Data.Array          as A
import           Z.Data.Parser.Base    (Parser)
import qualified Z.Data.Parser.Base    as P
import qualified Z.Data.Parser.Numeric as P
import qualified Z.Data.Vector         as V
import qualified Z.Data.Text           as T

-- | Parse a date of the form @[+,-]YYYY-MM-DD@.
--
-- Invalid date(leap year rule violation, etc.) will be rejected.
day :: Parser Day
{-# INLINE day #-}
day :: Parser Day
day = Text
"Date must be of form [+,-]YYYY-MM-DD" Text -> Parser Day -> Parser Day
forall a. Text -> Parser a -> Parser a
P.<?> do
    Integer
y <- (Parser Integer
P.integer Parser Integer -> Parser () -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Word8 -> Parser ()
P.word8 Word8
HYPHEN)
    Int
m <- (Parser Int
twoDigits Parser Int -> Parser () -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Word8 -> Parser ()
P.word8 Word8
HYPHEN)
    Int
d <- Parser Int
twoDigits
    case Integer -> Int -> Int -> Maybe Day
fromGregorianValid' Integer
y Int
m Int
d of
        Just Day
d' -> Day -> Parser Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
d'
        Maybe Day
_ -> Text -> Parser Day
forall a. Text -> Parser a
P.fail' (Text -> Parser Day) -> Text -> Parser Day
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"Z.Data.Parser.Time.day: invalid date: ", Integer -> Text
forall a. Print a => a -> Text
T.toText Integer
y, Text
"-", Int -> Text
forall a. Print a => a -> Text
T.toText Int
m, Text
"-", Int -> Text
forall a. Print a => a -> Text
T.toText Int
d]

-- | Faster 'fromGregorianValid' with 'fromGregorianValidInt64' as the common case path.
--
fromGregorianValid' :: Integer -> Int -> Int -> Maybe Day
{-# INLINE fromGregorianValid' #-}
fromGregorianValid' :: Integer -> Int -> Int -> Maybe Day
fromGregorianValid' Integer
y Int
m Int
d
    | -Integer
18000000000000000 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
y  Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
18000000000000000 = Int64 -> Int -> Int -> Maybe Day
fromGregorianValidInt64 (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y) Int
m Int
d
    | Bool
otherwise = Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d

-- | Faster common case for small years(around -18000000000000000 ~ 18000000000000000).
--
fromGregorianValidInt64 :: Int64 -> Int -> Int -> Maybe Day
{-# INLINABLE fromGregorianValidInt64 #-}
fromGregorianValidInt64 :: Int64 -> Int -> Int -> Maybe Day
fromGregorianValidInt64 Int64
year Int
month Int
day_ =
    if (Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
month Bool -> Bool -> Bool
&& Int
month Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
12) Bool -> Bool -> Bool
&& (Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
day_ Bool -> Bool -> Bool
&& Int
day_ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
monthLength)
    -- intentionally not to force with outer 'Just' here, we have done the grammar check, and calculating mjd is expensive,
    -- retained references are year, month and day, which are already in NF
    then Day -> Maybe Day
forall a. a -> Maybe a
Just (Integer -> Day
ModifiedJulianDay (Integer -> Day) -> Integer -> Day
forall a b. (a -> b) -> a -> b
$! Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
mjd)
    else Maybe Day
forall a. Maybe a
Nothing
  where
    isLeap :: Bool
isLeap = (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
rem Int64
year Int64
4 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) Bool -> Bool -> Bool
&& ((Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
rem Int64
year Int64
400 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) Bool -> Bool -> Bool
|| Bool -> Bool
not (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
rem Int64
year Int64
100 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0))
    dayOfYear :: Int
dayOfYear =
        let k :: Int
k = if Int
month Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 then Int
0 else if Bool
isLeap then -Int
1 else -Int
2
        in ((Int
367 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
month Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
362) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
12) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
day_
    mjd :: Int64
mjd =
        let y :: Int64
y = Int64
year Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1
        in (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dayOfYear) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (Int64
365 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
y) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
div Int64
y Int64
4) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
div Int64
y Int64
100) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
div Int64
y Int64
400) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
678576
    monthLength :: Int
monthLength = PrimArray Int -> Int -> Int
forall (arr :: * -> *) a.
(Arr arr a, HasCallStack) =>
arr a -> Int -> a
A.indexArr (if Bool
isLeap then PrimArray Int
monthListLeap else PrimArray Int
monthList) (Int
monthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

monthList :: A.PrimArray Int
{-# NOINLINE monthList #-}
monthList :: PrimArray Int
monthList = Int -> [Int] -> PrimArray Int
forall (v :: * -> *) a. Vec v a => Int -> [a] -> v a
V.packN Int
12 [ Int
31 , Int
28 , Int
31 , Int
30 , Int
31 , Int
30 , Int
31 , Int
31 , Int
30 , Int
31 , Int
30 , Int
31 ]

monthListLeap :: A.PrimArray Int
{-# NOINLINE monthListLeap #-}
monthListLeap :: PrimArray Int
monthListLeap = Int -> [Int] -> PrimArray Int
forall (v :: * -> *) a. Vec v a => Int -> [a] -> v a
V.packN Int
12 [ Int
31 , Int
29 , Int
31 , Int
30 , Int
31 , Int
30 , Int
31 , Int
31 , Int
30 , Int
31 , Int
30 , Int
31 ]

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: Parser Int
{-# INLINE twoDigits #-}
twoDigits :: Parser Int
twoDigits = do
    Int
a <- Parser Int
P.digit
    Int
b <- Parser Int
P.digit
    Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$! Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b

-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
timeOfDay :: Parser TimeOfDay
{-# INLINE timeOfDay #-}
timeOfDay :: Parser TimeOfDay
timeOfDay = do
    Int
h <- Parser Int
twoDigits
    Int
m <- Char -> Parser ()
P.char8 Char
':' Parser () -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
    Pico
s <- (Char -> Parser ()
P.char8 Char
':' Parser () -> Parser Pico -> Parser Pico
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Pico
seconds) Parser Pico -> Parser Pico -> Parser Pico
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pico -> Parser Pico
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pico
0
    if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60 Bool -> Bool -> Bool
&& Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< Pico
61
    then TimeOfDay -> Parser TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m Pico
s)
    else Text -> Parser TimeOfDay
forall a. Text -> Parser a
P.fail' Text
"invalid time"

-- | Parse a count of seconds, with the integer part being two digits -- long.
seconds :: Parser Pico
{-# INLINE seconds #-}
seconds :: Parser Pico
seconds = do
    Int
real <- Parser Int
twoDigits
    Maybe Word8
mw <- Parser (Maybe Word8)
P.peekMaybe
    case Maybe Word8
mw of
        Just Word8
DOT -> do
            Bytes
t <- Parser ()
P.skipWord8 Parser () -> Parser Bytes -> Parser Bytes
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser Bytes
P.takeWhile1 Word8 -> Bool
isDigit
            Pico -> Parser Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser Pico) -> Pico -> Parser Pico
forall a b. (a -> b) -> a -> b
$! Int -> Bytes -> Pico
forall k (v :: * -> *) a (a :: k).
(Vec v Word8, Integral a) =>
a -> v Word8 -> Fixed a
parsePicos Int
real Bytes
t
        Maybe Word8
_ -> Pico -> Parser Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser Pico) -> Pico -> Parser Pico
forall a b. (a -> b) -> a -> b
$! Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real
 where
    parsePicos :: a -> v Word8 -> Fixed a
parsePicos a
a0 v Word8
t =
        let V.IPair Int
n Int64
t'  = (IPair Int64 -> Word8 -> IPair Int64)
-> IPair Int64 -> v Word8 -> IPair Int64
forall (v :: * -> *) a b. Vec v a => (b -> a -> b) -> b -> v a -> b
V.foldl' IPair Int64 -> Word8 -> IPair Int64
forall a. Integral a => IPair a -> Word8 -> IPair a
step (Int -> Int64 -> IPair Int64
forall a. Int -> a -> IPair a
V.IPair Int
12 (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0 :: Int64)) v Word8
t
            step :: IPair a -> Word8 -> IPair a
step ma :: IPair a
ma@(V.IPair Int
m !a
a) Word8
w
                | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = IPair a
ma
                | Bool
otherwise = Int -> a -> IPair a
forall a. Int -> a -> IPair a
V.IPair (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (a
10 a -> a -> a
forall a. Num a => a -> a -> a
* a
a a -> a -> a
forall a. Num a => a -> a -> a
+ Word8 -> a
forall a. Integral a => Word8 -> a
P.w2iDec Word8
w)
        in Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
t' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZone :: Parser (Maybe TimeZone)
{-# INLINE timeZone #-}
timeZone :: Parser (Maybe TimeZone)
timeZone = do
    (Word8 -> Bool) -> Parser ()
P.skipWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
SPACE)
    Word8
w <- (Word8 -> Bool) -> Parser Word8
P.satisfy ((Word8 -> Bool) -> Parser Word8)
-> (Word8 -> Bool) -> Parser Word8
forall a b. (a -> b) -> a -> b
$ \ Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
LETTER_Z Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
PLUS Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
MINUS
    if Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
LETTER_Z
    then Maybe TimeZone -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
    else do
        Int
h <- Parser Int
twoDigits
        Maybe Word8
mm <- Parser (Maybe Word8)
P.peekMaybe
        Int
m <- case Maybe Word8
mm of
               Just Word8
COLON         -> Parser ()
P.skipWord8 Parser () -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
               Just Word8
d | Word8 -> Bool
isDigit Word8
d -> Parser Int
twoDigits
               Maybe Word8
_                  -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
        let off :: Int
off | Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
MINUS = Int -> Int
forall a. Num a => a -> a
negate Int
off0
                | Bool
otherwise  = Int
off0
            off0 :: Int
off0 = Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
        case () of
          ()
_   | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
                Maybe TimeZone -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
              | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< -Int
720 Bool -> Bool -> Bool
|| Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
840 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
59 ->
                String -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time zone offset"
              | Bool
otherwise ->
                    let !tz :: TimeZone
tz = Int -> TimeZone
minutesToTimeZone Int
off
                    in Maybe TimeZone -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> Maybe TimeZone
forall a. a -> Maybe a
Just TimeZone
tz)

-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.
-- The space may be replaced with a @T@.  The number of seconds is optional
-- and may be followed by a fractional component.
localTime :: Parser LocalTime
{-# INLINE localTime #-}
localTime :: Parser LocalTime
localTime = Day -> TimeOfDay -> LocalTime
LocalTime (Day -> TimeOfDay -> LocalTime)
-> Parser Day -> Parser (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Day
day Parser (TimeOfDay -> LocalTime)
-> Parser Word8 -> Parser (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
daySep Parser (TimeOfDay -> LocalTime)
-> Parser TimeOfDay -> Parser LocalTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TimeOfDay
timeOfDay
  where daySep :: Parser Word8
daySep = (Word8 -> Bool) -> Parser Word8
P.satisfy (\ Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
LETTER_T Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
SPACE)

-- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time.
utcTime :: Parser UTCTime
{-# INLINE utcTime #-}
utcTime :: Parser UTCTime
utcTime = do
    lt :: LocalTime
lt@(LocalTime Day
d TimeOfDay
t) <- Parser LocalTime
localTime
    Maybe TimeZone
mtz <- Parser (Maybe TimeZone)
timeZone
    case Maybe TimeZone
mtz of
        Maybe TimeZone
Nothing -> let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
t
                   in UTCTime -> Parser UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt)
        Just TimeZone
tz -> UTCTime -> Parser UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Parser UTCTime) -> UTCTime -> Parser UTCTime
forall a b. (a -> b) -> a -> b
$! TimeZone -> LocalTime -> UTCTime
localTimeToUTC TimeZone
tz LocalTime
lt

-- | Parse a date with time zone info. Acceptable formats:
--
-- @
--   YYYY-MM-DD HH:MM Z
--   YYYY-MM-DD HH:MM:SS Z
--   YYYY-MM-DD HH:MM:SS.SSS Z
-- @
--
-- The first space may instead be a @T@, and the second space is
-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a
-- time zone offset of the form @+0000@ or @-08:00@, where the first
-- two digits are hours, the @:@ is optional and the second two digits
-- (also optional) are minutes.
zonedTime :: Parser ZonedTime
{-# INLINE zonedTime #-}
zonedTime :: Parser ZonedTime
zonedTime = LocalTime -> TimeZone -> ZonedTime
ZonedTime (LocalTime -> TimeZone -> ZonedTime)
-> Parser LocalTime -> Parser (TimeZone -> ZonedTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LocalTime
localTime Parser (TimeZone -> ZonedTime)
-> Parser TimeZone -> Parser ZonedTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TimeZone -> Maybe TimeZone -> TimeZone
forall a. a -> Maybe a -> a
fromMaybe TimeZone
utc (Maybe TimeZone -> TimeZone)
-> Parser (Maybe TimeZone) -> Parser TimeZone
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe TimeZone)
timeZone)

utc :: TimeZone
{-# INLINE utc #-}
utc :: TimeZone
utc = Int -> Bool -> String -> TimeZone
TimeZone Int
0 Bool
False String
""