content: {-# language OverloadedStrings #-}
  {-# language TypeApplications #-}
  
  module Rel8.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 = do
    y <- A.decimal <* A.char '-'
    m <- twoDigits <* A.char '-'
    d <- twoDigits
    maybe (fail "Day: invalid date") pure $ fromGregorianValid y m d
  
  
  timeOfDay :: A.Parser TimeOfDay
  timeOfDay = do
    h <- 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 = LocalTime <$> day <* separator <*> timeOfDay
    where
      separator = A.char ' ' <|> A.char 'T'
  
  
  utcTime :: A.Parser UTCTime
  utcTime = do
    LocalTime date time <- localTime
    tz <- timeZone
    let
      (days, time') = (sinceMidnight time + tz) `divMod'` oneDay
        where
          oneDay = 24 * 60 * 60
      date' = addDays days date
    pure $ UTCTime date' time'
  
  
  calendarDiffTime :: A.Parser CalendarDiffTime
  calendarDiffTime = iso8601 <|> postgres
    where
      iso8601 = A.takeByteString >>= iso8601ParseM . UTF8.toString
      at = optional (A.char '@') *> A.skipSpace
      plural unit = A.skipSpace <* (unit <* optional "s") <* A.skipSpace
      parseMonths = sql <|> postgresql
        where
          sql = A.signed $ do
            years <- A.decimal <* A.char '-'
            months <- A.decimal <* A.skipSpace
            pure $ years * 12 + months
          postgresql = do
            at
            years <- A.signed A.decimal <* plural "year" <|> pure 0
            months <- A.signed A.decimal <* plural "mon" <|> pure 0
            pure $ years * 12 + months
      parseTime = (+) <$> parseDays <*> time
        where
          time = realToFrac <$> (sql <|> postgresql)
            where
              sql = A.signed $ do
                h <- A.signed A.decimal <* A.char ':'
                m <- twoDigits <* A.char ':'
                s <- secondsParser
                pure $ fromIntegral (((h * 60) + m) * 60) + s
              postgresql = do
                h <- A.signed A.decimal <* plural "hour" <|> pure 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 = do
            days <- A.signed A.decimal <* (plural "days" <|> skipSpace1) <|> pure 0
            pure $ fromIntegral @Int days * 24 * 60 * 60
      postgres = do
        months <- 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 = do
    integral <- twoDigits
    mfractional <- optional (A.char '.' *> A.takeWhile1 A.isDigit)
    pure $ case mfractional of
      Nothing -> fromIntegral integral
      Just fractional -> parseFraction (fromIntegral integral) fractional
   where
    parseFraction integral digits = MkFixed (fromIntegral (n * 10 ^ e))
      where
        e = max 0 (12 - BS.length digits)
        n = BS.foldl' go (integral :: Int64) (BS.take 12 digits)
          where
            go acc digit = 10 * acc + fromIntegral (fromEnum digit .&. 0xf)
  
  
  twoDigits :: A.Parser Int
  twoDigits = do
    u <- A.digit
    l <- A.digit
    pure $ fromEnum u .&. 0xf * 10 + fromEnum l .&. 0xf
  
  
  timeZone :: A.Parser DiffTime
  timeZone = 0 <$ A.char 'Z' <|> diffTime
  
  
  diffTime :: A.Parser DiffTime
  diffTime = A.signed $ do
    h <- twoDigits
    m <- A.char ':' *> twoDigits <|> pure 0
    s <- A.char ':' *> secondsParser <|> pure 0
    pure $ sinceMidnight $ TimeOfDay h m s
  
  
  skipSpace1 :: A.Parser ()
  skipSpace1 = void $ A.takeWhile1 A.isSpace
  