Parser.hs

{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

-- |
-- Module:      Database.PostgreSQL.Simple.Time.Internal.Parser
-- Copyright:   (c) 2012-2015 Leon P Smith
--              (c) 2015 Bryan O'Sullivan
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
-- Parsers for parsing dates and times.

module Database.PostgreSQL.Simple.Time.Internal.Parser
    (
      day
    , localTime
    , timeOfDay
    , timeZone
    , UTCOffsetHMS(..)
    , timeZoneHMS
    , localToUTCTimeOfDayHMS
    , utcTime
    , zonedTime
    , diffTime
    ) where

import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Data.Attoparsec.ByteString.Char8 (Parser, peekChar, anyChar, satisfy, option, digit, isDigit, char, takeWhile1, decimal)
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Fixed (Fixed (MkFixed), Pico)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorianValid, addDays)
import Data.Time.Clock (UTCTime(UTCTime), DiffTime, picosecondsToDiffTime)
import qualified Data.ByteString.Char8 as B8
import qualified Data.Time.LocalTime as Local

-- | Parse a date of the form @YYYY-MM-DD@.
day :: Parser Day
day = do
  y <- decimal <* char '-'
  m <- twoDigits <* char '-'
  d <- twoDigits
  maybe (fail "invalid date") return (fromGregorianValid y m d)

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: Parser Int
twoDigits = do
  a <- digit
  b <- digit
  return $! c2d a * 10 + c2d b

-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
timeOfDay :: Parser Local.TimeOfDay
timeOfDay = do
  h <- twoDigits <* char ':'
  m <- twoDigits
  mc <- peekChar
  s <- case mc of
         Just ':' -> anyChar *> seconds
         _   -> return 0
  if h < 24 && m < 60 && s <= 60
    then return (Local.TimeOfDay h m s)
    else fail "invalid time"

-- | Parse a count of seconds, with the integer part being two digits
-- long.
seconds :: Parser Pico
seconds = do
  real <- twoDigits
  mc <- peekChar
  case mc of
    Just '.' -> do
      t <- anyChar *> takeWhile1 isDigit
      return $! parsePicos (fromIntegral real) t
    _ -> return $! fromIntegral real
 where
  parsePicos :: Int64 -> B8.ByteString -> Pico
  parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
    where n  = max 0 (12 - B8.length t)
          t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
                         (B8.take 12 t)

-- TODO to check minus values, values which is smaller than an hour and so on
diffTime :: Parser DiffTime
diffTime = do
  h <- digits <* char ':'
  m <- toInteger <$> twoDigits <* char ':'
  MkFixed ps <- seconds
  return $ picosecondsToDiffTime $ (h * 60 + m) * 60 * 10 ^ (12 :: Int) + ps
  where
    digits =
      go 0
      where
        go acc = do
          md <- option Nothing $ Just . toInteger . c2d <$> digit
          case md of
            Just d -> go $ d + acc * 10
            Nothing -> return acc

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZone :: Parser (Maybe Local.TimeZone)
timeZone = do
  ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
  if ch == 'Z'
    then return Nothing
    else do
      h <- twoDigits
      mm <- peekChar
      m <- case mm of
             Just ':'           -> anyChar *> twoDigits
             _                  -> return 0
      let off | ch == '-' = negate off0
              | otherwise = off0
          off0 = h * 60 + m
      case () of
        _   | off == 0 ->
              return Nothing
            | h > 23 || m > 59 ->
              fail "invalid time zone offset"
            | otherwise ->
              let !tz = Local.minutesToTimeZone off
              in return (Just tz)

data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS = do
  ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
  if ch == 'Z'
    then return Nothing
    else do
      h <- twoDigits
      m <- maybeTwoDigits
      s <- maybeTwoDigits
      case () of
        _   | h == 0 && m == 0 && s == 0 ->
              return Nothing
            | h > 23 || m >= 60 || s >= 60 ->
              fail "invalid time zone offset"
            | otherwise ->
                if ch == '+'
                then let !tz = UTCOffsetHMS h m s
                      in return (Just tz)
                else let !tz = UTCOffsetHMS (-h) (-m) (-s)
                      in return (Just tz)
  where
    maybeTwoDigits = do
        ch <- peekChar
        case ch of
          Just ':' -> anyChar *> twoDigits
          _        -> return 0

localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
    (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
  where
    s' = s - fromIntegral ds
    (!s'', m')
        | s' < 0    = (s' + 60, m - dm - 1)
        | s' >= 60  = (s' - 60, m - dm + 1)
        | otherwise = (s'     , m - dm    )
    (!m'', h')
        | m' < 0    = (m' + 60, h - dh - 1)
        | m' >= 60  = (m' - 60, h - dh + 1)
        | otherwise = (m'     , h - dh    )
    h'' :: Int
    dday :: Integer
    (!h'', dday)
        | h' < 0    = (h' + 24, -1)
        | h' >= 24  = (h' - 24,  1)
        | otherwise = (h'     ,  0)


-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
-- The space may be replaced with a @T@.  The number of seconds may be
-- followed by a fractional component.
localTime :: Parser Local.LocalTime
localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
  where daySep = satisfy (\c -> c == ' ' || c == 'T')

-- | Behaves as 'zonedTime', but converts any time zone offset into a
-- UTC time.
utcTime :: Parser UTCTime
utcTime = do
  (Local.LocalTime d t) <- localTime
  mtz <- timeZoneHMS
  case mtz of
    Nothing -> let !tt = Local.timeOfDayToTime t
               in return (UTCTime d tt)
    Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
                   !d' = addDays dd d
                   !tt = Local.timeOfDayToTime t'
                in return (UTCTime d' tt)

-- | Parse a date with time zone info. Acceptable formats:
--
-- @YYYY-MM-DD HH:MM:SS 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 Local.ZonedTime
zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

c2d :: Char -> Int
c2d c = ord c .&. 15

utc :: Local.TimeZone
utc = Local.TimeZone 0 False ""

toPico :: Integer -> Pico
toPico = MkFixed