------------------------------------------------------------------------------
-- |
-- Module:      Database.SQLite.Simple.Time.Implementation
-- Copyright:   (c) 2012 Leon P Smith
--              (c) 2012-2014 Janne Hellsten
-- License:     BSD3
-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>
--
-- Adapted from Leon P Smith's code for SQLite.
--
-- See <http://sqlite.org/lang_datefunc.html> for date formats used in SQLite.
------------------------------------------------------------------------------

module Database.SQLite.Simple.Time.Implementation (
    parseUTCTime
  , parseDay
  , utcTimeToBuilder
  , dayToBuilder
  , timeOfDayToBuilder
  , timeZoneToBuilder
  ) where
import           Blaze.ByteString.Builder (Builder)
import           Blaze.ByteString.Builder.Char8 (fromChar)
import           Blaze.Text.Int (integral)
import           Control.Applicative
import           Control.Monad (when)
import qualified Data.Attoparsec.Text as A
import           Data.Bits ((.&.))
import           Data.ByteString.Internal (w2c)
import           Data.Char (isDigit, ord)
import           Data.Fixed (Pico)
import qualified Data.Text as T
import           Data.Time hiding (getTimeZone, getZonedTime)
import           Prelude hiding (take, (++))
import           Unsafe.Coerce

(++) :: Monoid a => a -> a -> a
++ :: a -> a -> a
(++) = a -> a -> a
forall a. Monoid a => a -> a -> a
mappend
infixr 5 ++

parseUTCTime   :: T.Text -> Either String UTCTime
parseUTCTime :: Text -> Either String UTCTime
parseUTCTime   = Parser UTCTime -> Text -> Either String UTCTime
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser UTCTime
getUTCTime Parser UTCTime -> Parser Text () -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseDay :: T.Text -> Either String Day
parseDay :: Text -> Either String Day
parseDay = Parser Day -> Text -> Either String Day
forall a. Parser a -> Text -> Either String a
A.parseOnly (Parser Day
getDay Parser Day -> Parser Text () -> Parser Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput)

getDay :: A.Parser Day
getDay :: Parser Day
getDay = do
    Text
yearStr <- (Char -> Bool) -> Parser Text
A.takeWhile Char -> Bool
isDigit
    Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Int
T.length Text
yearStr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4) (String -> Parser Text ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"year must consist of at least 4 digits")

    let !year :: Integer
year = Text -> Integer
forall n. Num n => Text -> n
toNum Text
yearStr
    Char
_       <- Char -> Parser Char
A.char Char
'-'
    Int
month   <- String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"month"
    Char
_       <- Char -> Parser Char
A.char Char
'-'
    Int
day     <- String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"day"

    case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
year Int
month Int
day of
      Maybe Day
Nothing -> String -> Parser Day
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date"
      Just Day
x  -> Day -> Parser Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> Parser Day) -> Day -> Parser Day
forall a b. (a -> b) -> a -> b
$! Day
x

decimal :: Fractional a => T.Text -> a
decimal :: Text -> a
decimal Text
str = Text -> a
forall n. Num n => Text -> n
toNum Text
str a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
10a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Text -> Int
T.length Text
str)
{-# INLINE decimal #-}

getTimeOfDay :: A.Parser TimeOfDay
getTimeOfDay :: Parser TimeOfDay
getTimeOfDay = do
    Int
hour   <- String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"hours"
    Char
_      <- Char -> Parser Char
A.char Char
':'
    Int
minute <- String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"minutes"
    -- Allow omission of seconds.  If seconds is omitted, don't try to
    -- parse the sub-second part.
    (Pico
sec,Pico
subsec)
           <- ((,) (Pico -> Pico -> (Pico, Pico))
-> Parser Text Pico -> Parser Text (Pico -> (Pico, Pico))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
A.char Char
':' Parser Char -> Parser Text Pico -> Parser Text Pico
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Parser Text Pico
forall n. Num n => String -> Parser n
digits String
"seconds") Parser Text (Pico -> (Pico, Pico))
-> Parser Text Pico -> Parser Text (Pico, Pico)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Pico
fract) Parser Text (Pico, Pico)
-> Parser Text (Pico, Pico) -> Parser Text (Pico, Pico)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Pico, Pico) -> Parser Text (Pico, Pico)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pico
0,Pico
0)

    let !picos' :: Pico
picos' = Pico
sec Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ Pico
subsec

    case Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid Int
hour Int
minute Pico
picos' of
      Maybe TimeOfDay
Nothing -> String -> Parser TimeOfDay
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time of day"
      Just TimeOfDay
x  -> TimeOfDay -> Parser TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeOfDay -> Parser TimeOfDay) -> TimeOfDay -> Parser TimeOfDay
forall a b. (a -> b) -> a -> b
$! TimeOfDay
x

    where
      fract :: Parser Text Pico
fract =
        (Char -> Parser Char
A.char Char
'.' Parser Char -> Parser Text Pico -> Parser Text Pico
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Pico
forall a. Fractional a => Text -> a
decimal (Text -> Pico) -> Parser Text -> Parser Text Pico
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
A.takeWhile1 Char -> Bool
isDigit)) Parser Text Pico -> Parser Text Pico -> Parser Text Pico
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Pico -> Parser Text Pico
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pico
0

getTimeZone :: A.Parser TimeZone
getTimeZone :: Parser TimeZone
getTimeZone = do
    Char
sign  <- (Char -> Bool) -> Parser Char
A.satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
    Int
hours <- String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"timezone"
    Int
mins  <- (Char -> Parser Char
A.char Char
':' Parser Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Parser Int
forall n. Num n => String -> Parser n
digits String
"timezone minutes") Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
    let !absset :: Int
absset = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hours Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mins
        !offset :: Int
offset = if Char
sign Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' then Int
absset else -Int
absset
    TimeZone -> Parser TimeZone
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> Parser TimeZone) -> TimeZone -> Parser TimeZone
forall a b. (a -> b) -> a -> b
$! Int -> TimeZone
minutesToTimeZone Int
offset

getUTCTime :: A.Parser UTCTime
getUTCTime :: Parser UTCTime
getUTCTime = do
    Day
day  <- Parser Day
getDay
    Char
_    <- Char -> Parser Char
A.char Char
' ' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'T'
    TimeOfDay
time <- Parser TimeOfDay
getTimeOfDay
    -- SQLite doesn't require a timezone postfix.  So make that
    -- optional and default to +0.  'Z' means UTC (zulu time).
    TimeZone
zone <- Parser TimeZone
getTimeZone Parser TimeZone -> Parser TimeZone -> Parser TimeZone
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
A.char Char
'Z' Parser Char -> Parser TimeZone -> Parser TimeZone
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TimeZone -> Parser TimeZone
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeZone
utc) Parser TimeZone -> Parser TimeZone -> Parser TimeZone
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TimeZone -> Parser TimeZone
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeZone
utc)
    let (!Integer
dayDelta,!TimeOfDay
time') = TimeZone -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDay TimeZone
zone TimeOfDay
time
    let !day' :: Day
day' = Integer -> Day -> Day
addDays Integer
dayDelta Day
day
    let !time'' :: DiffTime
time'' = TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
time'
    UTCTime -> Parser UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
day' DiffTime
time'')

toNum :: Num n => T.Text -> n
toNum :: Text -> n
toNum = (n -> Char -> n) -> n -> Text -> n
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (\n
a Char
c -> n
10n -> n -> n
forall a. Num a => a -> a -> a
*n
a n -> n -> n
forall a. Num a => a -> a -> a
+ Char -> n
forall n. Num n => Char -> n
digit Char
c) n
0
{-# INLINE toNum #-}

digit :: Num n => Char -> n
digit :: Char -> n
digit Char
c = Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x0f)
{-# INLINE digit #-}

digits :: Num n => String -> A.Parser n
digits :: String -> Parser n
digits String
msg = do
  Char
x <- Parser Char
A.anyChar
  Char
y <- Parser Char
A.anyChar
  if Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
y
  then n -> Parser n
forall (m :: * -> *) a. Monad m => a -> m a
return (n -> Parser n) -> n -> Parser n
forall a b. (a -> b) -> a -> b
$! (n
10 n -> n -> n
forall a. Num a => a -> a -> a
* Char -> n
forall n. Num n => Char -> n
digit Char
x n -> n -> n
forall a. Num a => a -> a -> a
+ Char -> n
forall n. Num n => Char -> n
digit Char
y)
  else String -> Parser n
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
msg String -> String -> String
forall a. Monoid a => a -> a -> a
++ String
" is not 2 digits")
{-# INLINE digits #-}

dayToBuilder :: Day -> Builder
dayToBuilder :: Day -> Builder
dayToBuilder (Day -> (Integer, Int, Int)
toGregorian -> (Integer
y,Int
m,Int
d)) = do
    Integer -> Builder
forall n. (Integral n, Show n) => n -> Builder
pad4 Integer
y Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
'-' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
m Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
'-' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
d

timeOfDayToBuilder :: TimeOfDay -> Builder
timeOfDayToBuilder :: TimeOfDay -> Builder
timeOfDayToBuilder (TimeOfDay Int
h Int
m Pico
s) = do
    Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
h Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
':' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
m Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
':' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Pico -> Builder
showSeconds Pico
s

timeZoneToBuilder :: TimeZone -> Builder
timeZoneToBuilder :: TimeZone -> Builder
timeZoneToBuilder TimeZone
tz
    | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0     =  Int -> Builder
forall a. (Ord a, Num a) => a -> Builder
sign Int
h Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 (Int -> Int
forall a. Num a => a -> a
abs Int
h)
    | Bool
otherwise  =  Int -> Builder
forall a. (Ord a, Num a) => a -> Builder
sign Int
h Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 (Int -> Int
forall a. Num a => a -> a
abs Int
h) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
':' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
pad2 (Int -> Int
forall a. Num a => a -> a
abs Int
m)
  where
    (Int
h,Int
m) = TimeZone -> Int
timeZoneMinutes TimeZone
tz Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
60
    sign :: a -> Builder
sign a
h | a
h a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0    = Char -> Builder
fromChar Char
'+'
           | Bool
otherwise = Char -> Builder
fromChar Char
'-'

-- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part.
-- Explicit timezone attribute is not appended as per SQLite3's
-- datetime conventions.
utcTimeToBuilder :: UTCTime -> Builder
utcTimeToBuilder :: UTCTime -> Builder
utcTimeToBuilder (UTCTime Day
day DiffTime
time) =
    Day -> Builder
dayToBuilder Day
day Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
' ' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ TimeOfDay -> Builder
timeOfDayToBuilder (DiffTime -> TimeOfDay
timeToTimeOfDay DiffTime
time)

showSeconds :: Pico -> Builder
showSeconds :: Pico -> Builder
showSeconds Pico
xyz
    | Integer
yz Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0   = Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
x
    | Int
z  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0   = Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
'.' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++  Int -> Builder
showD6 Int
y
    | Bool
otherwise = Int -> Builder
forall n. Integral n => n -> Builder
pad2 Int
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Char -> Builder
fromChar Char
'.' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++  Int -> Builder
pad6   Int
y Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
showD6 Int
z
  where
    -- A kludge to work around the fact that Data.Fixed isn't very fast and
    -- doesn't give me access to the MkFixed constructor.
    (Integer
x_,Integer
yz) = (Pico -> Integer
forall a b. a -> b
unsafeCoerce Pico
xyz :: Integer)     Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
1000000000000
    x :: Int
x = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x_ :: Int
    (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
y, Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
z) = Integer
yz Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
1000000

pad6 :: Int -> Builder
pad6 :: Int -> Builder
pad6 Int
xy = let (Int
x,Int
y) = Int
xy Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
1000
           in Int -> Builder
pad3 Int
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
pad3 Int
y

showD6 :: Int -> Builder
showD6 :: Int -> Builder
showD6 Int
xy = case Int
xy Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
1000 of
              (Int
x,Int
0) -> Int -> Builder
showD3 Int
x
              (Int
x,Int
y) -> Int -> Builder
pad3 Int
x Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
showD3 Int
y

pad3 :: Int -> Builder
pad3 :: Int -> Builder
pad3 Int
abc = let (Int
ab,Int
c) = Int
abc Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10
               (Int
a,Int
b)  = Int
ab  Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10
            in Int -> Builder
forall n. Integral n => n -> Builder
p Int
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
p Int
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
p Int
c

showD3 :: Int -> Builder
showD3 :: Int -> Builder
showD3 Int
abc = case Int
abc Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
100 of
              (Int
a, Int
0) -> Int -> Builder
forall n. Integral n => n -> Builder
p Int
a
              (Int
a,Int
bc) -> case Int
bc Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10 of
                          (Int
b,Int
0) -> Int -> Builder
forall n. Integral n => n -> Builder
p Int
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
p Int
b
                          (Int
b,Int
c) -> Int -> Builder
forall n. Integral n => n -> Builder
p Int
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
p Int
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ Int -> Builder
forall n. Integral n => n -> Builder
p Int
c

-- | p assumes its input is in the range [0..9]
p :: Integral n => n -> Builder
p :: n -> Builder
p n
n = Char -> Builder
fromChar (Word8 -> Char
w2c (n -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (n
n n -> n -> n
forall a. Num a => a -> a -> a
+ n
48)))
{-# INLINE p #-}

-- | pad2 assumes its input is in the range [0..99]
pad2 :: Integral n => n -> Builder
pad2 :: n -> Builder
pad2 n
n = let (n
a,n
b) = n
n n -> n -> (n, n)
forall a. Integral a => a -> a -> (a, a)
`quotRem` n
10 in n -> Builder
forall n. Integral n => n -> Builder
p n
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ n -> Builder
forall n. Integral n => n -> Builder
p n
b
{-# INLINE pad2 #-}

-- | pad4 assumes its input is positive
pad4 :: (Integral n, Show n) => n -> Builder
pad4 :: n -> Builder
pad4 n
abcd | n
abcd n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
10000 = n -> Builder
forall n. (Integral n, Show n) => n -> Builder
integral n
abcd
          | Bool
otherwise     = n -> Builder
forall n. Integral n => n -> Builder
p n
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ n -> Builder
forall n. Integral n => n -> Builder
p n
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ n -> Builder
forall n. Integral n => n -> Builder
p n
c Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
++ n -> Builder
forall n. Integral n => n -> Builder
p n
d
  where (n
ab,n
cd) = n
abcd n -> n -> (n, n)
forall a. Integral a => a -> a -> (a, a)
`quotRem` n
100
        (n
a,n
b)   = n
ab   n -> n -> (n, n)
forall a. Integral a => a -> a -> (a, a)
`quotRem` n
10
        (n
c,n
d)   = n
cd   n -> n -> (n, n)
forall a. Integral a => a -> a -> (a, a)
`quotRem` n
10
{-# INLINE pad4 #-}