{-# language OverloadedStrings #-}
{-# language TypeApplications #-}

module Rel8.Internal.Type.Parser.Time
  ( calendarDiffTime
  , day
  , localTime
  , timeOfDay
  , utcTime
  )
where

-- attoparsec
import qualified Data.Attoparsec.ByteString.Char8 as A

-- base
import Control.Applicative ((<|>), optional)
import Data.Bits ((.&.))
import Data.Bool (bool)
import Data.Fixed (Fixed (MkFixed), Pico, divMod')
import Data.Functor (void)
import Data.Int (Int64)
import Prelude

-- bytestring
import qualified Data.ByteString as BS

-- time
import Data.Time.Calendar (Day, addDays, fromGregorianValid)
import Data.Time.Clock (DiffTime, UTCTime (UTCTime))
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Data.Time.LocalTime
  ( CalendarDiffTime (CalendarDiffTime)
  , LocalTime (LocalTime)
  , TimeOfDay (TimeOfDay)
  , sinceMidnight
  )

-- utf8
import qualified Data.ByteString.UTF8 as UTF8


day :: A.Parser Day
day :: Parser Day
day = do
  y <- Parser Integer
forall a. Integral a => Parser a
A.decimal Parser Integer -> Parser ByteString Char -> Parser Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'-'
  m <- twoDigits <* A.char '-'
  d <- twoDigits
  maybe (fail "Day: invalid date") pure $ fromGregorianValid y m d


timeOfDay :: A.Parser TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
  h <- Parser Int
twoDigits
  m <- A.char ':' *> twoDigits
  s <- A.char ':' *> secondsParser
  if h < 24 && m < 60 && s <= 60
    then pure $ TimeOfDay h m s
    else fail "TimeOfDay: invalid time"


localTime :: A.Parser LocalTime
localTime :: Parser LocalTime
localTime = Day -> TimeOfDay -> LocalTime
LocalTime (Day -> TimeOfDay -> LocalTime)
-> Parser Day -> Parser ByteString (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Day
day Parser ByteString (TimeOfDay -> LocalTime)
-> Parser ByteString Char
-> Parser ByteString (TimeOfDay -> LocalTime)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
separator Parser ByteString (TimeOfDay -> LocalTime)
-> Parser TimeOfDay -> Parser LocalTime
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TimeOfDay
timeOfDay
  where
    separator :: Parser ByteString Char
separator = Char -> Parser ByteString Char
A.char Char
' ' Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString Char
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser ByteString Char
A.char Char
'T'


utcTime :: A.Parser UTCTime
utcTime :: Parser UTCTime
utcTime = do
  LocalTime date time <- Parser LocalTime
localTime
  tz <- timeZone
  let
    (days, time') = (sinceMidnight time + tz) `divMod'` oneDay
      where
        oneDay = DiffTime
24 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60
    date' = Integer -> Day -> Day
addDays Integer
days Day
date
  pure $ UTCTime date' time'


calendarDiffTime :: A.Parser CalendarDiffTime
calendarDiffTime :: Parser CalendarDiffTime
calendarDiffTime = Parser CalendarDiffTime
iso8601 Parser CalendarDiffTime
-> Parser CalendarDiffTime -> Parser CalendarDiffTime
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser CalendarDiffTime
postgres
  where
    iso8601 :: Parser CalendarDiffTime
iso8601 = Parser ByteString
A.takeByteString Parser ByteString
-> (ByteString -> Parser CalendarDiffTime)
-> Parser CalendarDiffTime
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Parser CalendarDiffTime
forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM (String -> Parser CalendarDiffTime)
-> (ByteString -> String) -> ByteString -> Parser CalendarDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8.toString
    at :: Parser ByteString ()
at = Parser ByteString Char -> Parser ByteString (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser ByteString Char
A.char Char
'@') Parser ByteString (Maybe Char)
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
A.skipSpace
    plural :: Parser ByteString b -> Parser ByteString ()
plural Parser ByteString b
unit = Parser ByteString ()
A.skipSpace Parser ByteString () -> Parser ByteString b -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser ByteString b
unit Parser ByteString b
-> Parser ByteString (Maybe ByteString) -> Parser ByteString b
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString -> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString
"s") Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
A.skipSpace
    parseMonths :: Parser Integer
parseMonths = Parser Integer
sql Parser Integer -> Parser Integer -> Parser Integer
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Integer
postgresql
      where
        sql :: Parser Integer
sql = Parser Integer -> Parser Integer
forall a. Num a => Parser a -> Parser a
A.signed (Parser Integer -> Parser Integer)
-> Parser Integer -> Parser Integer
forall a b. (a -> b) -> a -> b
$ do
          years <- Parser Integer
forall a. Integral a => Parser a
A.decimal Parser Integer -> Parser ByteString Char -> Parser Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'-'
          months <- A.decimal <* A.skipSpace
          pure $ years * 12 + months
        postgresql :: Parser Integer
postgresql = do
          Parser ByteString ()
at
          years <- Parser Integer -> Parser Integer
forall a. Num a => Parser a -> Parser a
A.signed Parser Integer
forall a. Integral a => Parser a
A.decimal Parser Integer -> Parser ByteString () -> Parser Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString -> Parser ByteString ()
forall {b}. Parser ByteString b -> Parser ByteString ()
plural Parser ByteString
"year" Parser Integer -> Parser Integer -> Parser Integer
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Parser Integer
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
          months <- A.signed A.decimal <* plural "mon" <|> pure 0
          pure $ years * 12 + months
    parseTime :: Parser ByteString NominalDiffTime
parseTime = NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
(+) (NominalDiffTime -> NominalDiffTime -> NominalDiffTime)
-> Parser ByteString NominalDiffTime
-> Parser ByteString (NominalDiffTime -> NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NominalDiffTime
parseDays Parser ByteString (NominalDiffTime -> NominalDiffTime)
-> Parser ByteString NominalDiffTime
-> Parser ByteString NominalDiffTime
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString NominalDiffTime
time
      where
        time :: Parser ByteString NominalDiffTime
time = Fixed E12 -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Fixed E12 -> NominalDiffTime)
-> Parser ByteString (Fixed E12)
-> Parser ByteString NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString (Fixed E12)
sql Parser ByteString (Fixed E12)
-> Parser ByteString (Fixed E12) -> Parser ByteString (Fixed E12)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Fixed E12)
postgresql)
          where
            sql :: Parser ByteString (Fixed E12)
sql = Parser ByteString (Fixed E12) -> Parser ByteString (Fixed E12)
forall a. Num a => Parser a -> Parser a
A.signed (Parser ByteString (Fixed E12) -> Parser ByteString (Fixed E12))
-> Parser ByteString (Fixed E12) -> Parser ByteString (Fixed E12)
forall a b. (a -> b) -> a -> b
$ do
              h <- Parser Int -> Parser Int
forall a. Num a => Parser a -> Parser a
A.signed Parser Int
forall a. Integral a => Parser a
A.decimal Parser Int -> Parser ByteString Char -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
':'
              m <- twoDigits <* A.char ':'
              s <- secondsParser
              pure $ fromIntegral (((h * 60) + m) * 60) + s
            postgresql :: Parser ByteString (Fixed E12)
postgresql = do
              h <- Parser Int -> Parser Int
forall a. Num a => Parser a -> Parser a
A.signed Parser Int
forall a. Integral a => Parser a
A.decimal Parser Int -> Parser ByteString () -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString -> Parser ByteString ()
forall {b}. Parser ByteString b -> Parser ByteString ()
plural Parser ByteString
"hour" Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Int
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
              m <- A.signed A.decimal <* plural "min" <|> pure 0
              s <- secondsParser <* plural "sec" <|> pure 0
              pure $ fromIntegral @Int (((h * 60) + m) * 60) + s
        parseDays :: Parser ByteString NominalDiffTime
parseDays = do
          days <- Parser Int -> Parser Int
forall a. Num a => Parser a -> Parser a
A.signed Parser Int
forall a. Integral a => Parser a
A.decimal Parser Int -> Parser ByteString () -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser ByteString -> Parser ByteString ()
forall {b}. Parser ByteString b -> Parser ByteString ()
plural Parser ByteString
"days" Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ()
skipSpace1) Parser Int -> Parser Int -> Parser Int
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Int
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
          pure $ fromIntegral @Int days * 24 * 60 * 60
    postgres :: Parser CalendarDiffTime
postgres = do
      months <- Parser Integer
parseMonths
      time <- parseTime
      ago <- (True <$ (A.skipSpace *> "ago")) <|> pure False
      pure $ CalendarDiffTime (bool id negate ago months) (bool id negate ago time)


secondsParser :: A.Parser Pico
secondsParser :: Parser ByteString (Fixed E12)
secondsParser = do
  integral <- Parser Int
twoDigits
  mfractional <- optional (A.char '.' *> A.takeWhile1 A.isDigit)
  pure $ case mfractional of
    Maybe ByteString
Nothing -> Int -> Fixed E12
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
integral
    Just ByteString
fractional -> Int64 -> ByteString -> Fixed E12
forall {a}. Int64 -> ByteString -> Fixed a
parseFraction (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
integral) ByteString
fractional
 where
  parseFraction :: Int64 -> ByteString -> Fixed a
parseFraction Int64
integral ByteString
digits = Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10 Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e))
    where
      e :: Int
e = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
digits)
      n :: Int64
n = (Int64 -> Word8 -> Int64) -> Int64 -> ByteString -> Int64
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Int64 -> Word8 -> Int64
forall {a} {a}. (Num a, Enum a) => a -> a -> a
go (Int64
integral :: Int64) (Int -> ByteString -> ByteString
BS.take Int
12 ByteString
digits)
        where
          go :: a -> a -> a
go a
acc a
digit = a
10 a -> a -> a
forall a. Num a => a -> a -> a
* a
acc a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Enum a => a -> Int
fromEnum a
digit Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf)


twoDigits :: A.Parser Int
twoDigits :: Parser Int
twoDigits = do
  u <- Parser ByteString Char
A.digit
  l <- A.digit
  pure $ fromEnum u .&. 0xf * 10 + fromEnum l .&. 0xf


timeZone :: A.Parser DiffTime
timeZone :: Parser DiffTime
timeZone = DiffTime
0 DiffTime -> Parser ByteString Char -> Parser DiffTime
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
A.char Char
'Z' Parser DiffTime -> Parser DiffTime -> Parser DiffTime
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser DiffTime
diffTime


diffTime :: A.Parser DiffTime
diffTime :: Parser DiffTime
diffTime = Parser DiffTime -> Parser DiffTime
forall a. Num a => Parser a -> Parser a
A.signed (Parser DiffTime -> Parser DiffTime)
-> Parser DiffTime -> Parser DiffTime
forall a b. (a -> b) -> a -> b
$ do
  h <- Parser Int
twoDigits
  m <- A.char ':' *> twoDigits <|> pure 0
  s <- A.char ':' *> secondsParser <|> pure 0
  pure $ sinceMidnight $ TimeOfDay h m s


skipSpace1 :: A.Parser ()
skipSpace1 :: Parser ByteString ()
skipSpace1 = Parser ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString -> Parser ByteString ())
-> Parser ByteString -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile1 Char -> Bool
A.isSpace