{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module:      Data.Time.Parsers (Data.Aeson.Parser.Time)
-- Copyright:   (c) 2015 Bryan O'Sullivan, 2015 Oleg Grenrus
-- License:     BSD3
-- Maintainer:  Oleg Grenrus <oleg.grenrus@iki.fi>
--
-- Parsers for parsing dates and times.

module Data.Time.Parsers
    ( day
    , month
    , localTime
    , timeOfDay
    , timeZone
    , utcTime
    , zonedTime
    , DateParsing
    ) where

import Control.Applicative     (optional, some, (<|>))
import Control.Monad           (void, when)
import Data.Bits               ((.&.))
import Data.Char               (isDigit, ord)
import Data.Fixed              (Pico)
import Data.Int                (Int64)
import Data.List               (foldl')
import Data.Maybe              (fromMaybe)
import Data.Time.Calendar      (Day, fromGregorianValid)
import Data.Time.Clock         (UTCTime (..))
import Text.Parser.Char        (CharParsing (..), digit)
import Text.Parser.Combinators (unexpected)
import Text.Parser.LookAhead   (LookAheadParsing (..))
import Unsafe.Coerce           (unsafeCoerce)

import qualified Data.Time.LocalTime as Local

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>))
#endif

type DateParsing m = (CharParsing m, LookAheadParsing m, Monad m)

toPico :: Integer -> Pico
toPico :: Integer -> Pico
toPico = Integer -> Pico
forall a b. a -> b
unsafeCoerce

-- | Parse a month of the form @YYYY-MM@
month :: DateParsing m => m (Integer, Int)
month :: m (Integer, Int)
month = do
  Integer -> Integer
s <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '-' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '+' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> m (Integer -> Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer
forall a. a -> a
id
  Integer
y <- m Integer
forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal
  Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '-'
  Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
  if (1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
m Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 12)
      then (Integer, Int) -> m (Integer, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer
s Integer
y, Int
m)
      else String -> m (Integer, Int)
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected "Invalid month"
{-# INLINE month #-}

-- | Parse a date of the form @YYYY-MM-DD@.
day :: DateParsing m => m Day
day :: m Day
day = do
  Integer -> Integer
s <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '-' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '+' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> m (Integer -> Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer
forall a. a -> a
id
  Integer
y <- m Integer
forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal
  Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '-'
  Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
  Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '-'
  Int
d <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
  m Day -> (Day -> m Day) -> Maybe Day -> m Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Day
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected "invalid date") Day -> m Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Integer -> Integer
s Integer
y) Int
m Int
d)

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: DateParsing m => m Int
twoDigits :: m Int
twoDigits = do
  Char
a <- m Char
forall (m :: * -> *). CharParsing m => m Char
digit
  Char
b <- m Char
forall (m :: * -> *). CharParsing m => m Char
digit
  let c2d :: Char -> Int
c2d c :: Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 15
  Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$! Char -> Int
c2d Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
c2d Char
b

-- | Parse a time of the form @HH:MM:SS[.SSS]@.
timeOfDay :: DateParsing m => m Local.TimeOfDay
timeOfDay :: m TimeOfDay
timeOfDay = do
  Int
h <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits m Int -> m Char -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char ':'
  Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits m Int -> m Char -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char ':'
  Pico
s <- m Pico
forall (m :: * -> *). DateParsing m => m Pico
seconds
  if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 24 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 60 Bool -> Bool -> Bool
&& Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< 61
    then TimeOfDay -> m TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Pico -> TimeOfDay
Local.TimeOfDay Int
h Int
m Pico
s)
    else String -> m TimeOfDay
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected "invalid time"

data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64

-- | Parse a count of seconds, with the integer part being two digits
-- long.
seconds :: DateParsing m => m Pico
seconds :: m Pico
seconds = do
  Int
real <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
  Maybe Char
mc <- m (Maybe Char)
forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
  case Maybe Char
mc of
    Just '.' -> do
      String
t <- m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar m Char -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
forall (m :: * -> *). CharParsing m => m Char
digit
      Pico -> m Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> m Pico) -> Pico -> m Pico
forall a b. (a -> b) -> a -> b
$! Int -> String -> Pico
forall (t :: * -> *) a.
(Foldable t, Integral a) =>
a -> t Char -> Pico
parsePicos Int
real String
t
    _ -> Pico -> m Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> m Pico) -> Pico -> m 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 -> t Char -> Pico
parsePicos a0 :: a
a0 t :: t Char
t = Integer -> Pico
toPico (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
t' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* 10Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))
    where T n :: Int
n t' :: Int64
t'  = (T -> Char -> T) -> T -> t Char -> T
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' T -> Char -> T
step (Int -> Int64 -> T
T 12 (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0)) t Char
t
          step :: T -> Char -> T
step ma :: T
ma@(T m :: Int
m a :: Int64
a) c :: Char
c
              | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0    = T
ma
              | Bool
otherwise = Int -> Int64 -> T
T (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
a Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. 15)

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZone :: DateParsing m => m (Maybe Local.TimeZone)
timeZone :: m (Maybe TimeZone)
timeZone = do
  let maybeSkip :: Char -> m ()
maybeSkip c :: Char
c = do Char
ch <- m Char
forall (m :: * -> *). DateParsing m => m Char
peekChar'; Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) (m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar)
  Char -> m ()
forall (m :: * -> *).
(Monad m, CharParsing m, LookAheadParsing m) =>
Char -> m ()
maybeSkip ' '
  Char
ch <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'
  if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z'
    then Maybe TimeZone -> m (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
    else do
      Int
h <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
      Maybe Char
mm <- m (Maybe Char)
forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
      Int
m <- case Maybe Char
mm of
             Just ':'           -> m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar m Char -> m Int -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
             Just d :: Char
d | Char -> Bool
isDigit Char
d -> m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
             _                  -> Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
      let off :: Int
off | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' = 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
* 60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
      case Any
forall a. HasCallStack => a
undefined of
        _   | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 ->
              Maybe TimeZone -> m (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
< -720 Bool -> Bool -> Bool
|| Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 840 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 59 ->
              String -> m (Maybe TimeZone)
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected "invalid time zone offset"
            | Bool
otherwise ->
              let !tz :: TimeZone
tz = Int -> TimeZone
Local.minutesToTimeZone Int
off
              in Maybe TimeZone -> m (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@.
-- The space may be replaced with a @T@.  The number of seconds may be
-- followed by a fractional component.
localTime :: DateParsing m => m Local.LocalTime
localTime :: m LocalTime
localTime = Day -> TimeOfDay -> LocalTime
Local.LocalTime (Day -> TimeOfDay -> LocalTime)
-> m Day -> m (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Day
forall (m :: * -> *). DateParsing m => m Day
day m (TimeOfDay -> LocalTime) -> m Char -> m (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Char
daySep m (TimeOfDay -> LocalTime) -> m TimeOfDay -> m LocalTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m TimeOfDay
forall (m :: * -> *). DateParsing m => m TimeOfDay
timeOfDay
  where daySep :: m Char
daySep = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'T' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')

-- | Behaves as 'zonedTime', but converts any time zone offset into a
-- UTC time.
utcTime :: DateParsing m => m UTCTime
utcTime :: m UTCTime
utcTime = LocalTime -> Maybe TimeZone -> UTCTime
f (LocalTime -> Maybe TimeZone -> UTCTime)
-> m LocalTime -> m (Maybe TimeZone -> UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LocalTime
forall (m :: * -> *). DateParsing m => m LocalTime
localTime m (Maybe TimeZone -> UTCTime) -> m (Maybe TimeZone) -> m UTCTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Maybe TimeZone)
forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone
  where
    f :: Local.LocalTime -> Maybe Local.TimeZone -> UTCTime
    f :: LocalTime -> Maybe TimeZone -> UTCTime
f (Local.LocalTime d :: Day
d t :: TimeOfDay
t) Nothing =
        let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
Local.timeOfDayToTime TimeOfDay
t
        in Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt
    f lt :: LocalTime
lt (Just tz :: TimeZone
tz) = TimeZone -> LocalTime -> UTCTime
Local.localTimeToUTC TimeZone
tz LocalTime
lt

-- | 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 :: DateParsing m => m Local.ZonedTime
zonedTime :: m ZonedTime
zonedTime = LocalTime -> TimeZone -> ZonedTime
Local.ZonedTime (LocalTime -> TimeZone -> ZonedTime)
-> m LocalTime -> m (TimeZone -> ZonedTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LocalTime
forall (m :: * -> *). DateParsing m => m LocalTime
localTime m (TimeZone -> ZonedTime) -> m TimeZone -> m 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) -> m (Maybe TimeZone) -> m TimeZone
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe TimeZone)
forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone)

utc :: Local.TimeZone
utc :: TimeZone
utc = Int -> Bool -> String -> TimeZone
Local.TimeZone 0 Bool
False ""

decimal :: (DateParsing m, Integral a) => m a
decimal :: m a
decimal = (a -> Char -> a) -> a -> String -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Char -> a
forall a. Num a => a -> Char -> a
step 0 (String -> a) -> m String -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
forall (m :: * -> *). CharParsing m => m Char
digit
  where step :: a -> Char -> a
step a :: a
a w :: Char
w = a
a a -> a -> a
forall a. Num a => a -> a -> a
* 10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 48)

peekChar :: DateParsing m => m (Maybe Char)
peekChar :: m (Maybe Char)
peekChar = m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Char
forall (m :: * -> *). DateParsing m => m Char
peekChar'

peekChar' :: DateParsing m => m Char
peekChar' :: m Char
peekChar' = m Char -> m Char
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
lookAhead m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar