{-# LANGUAGE BangPatterns, ViewPatterns #-}

------------------------------------------------------------------------------
-- Module:      Database.PostgreSQL.Simple.Time.Internal.Printer
-- Copyright:   (c) 2012-2015 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.Time.Internal.Printer
    (
      day
    , timeOfDay
    , timeZone
    , utcTime
    , localTime
    , zonedTime
    , nominalDiffTime
    , calendarDiffTime
    ) where

import Control.Arrow ((>>>))
import Data.ByteString.Builder (Builder, byteString, integerDec)
import Data.ByteString.Builder.Prim
    ( liftFixedToBounded, (>$<), (>*<)
    , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
import Data.Char ( chr )
import Data.Int ( Int32, Int64 )
import Data.String (fromString)
import Data.Time.Compat
    ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
    , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
    , TimeZone, timeZoneMinutes )
import Data.Time.Format.ISO8601.Compat (iso8601Show)
import Data.Time.LocalTime.Compat (CalendarDiffTime)
import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
import Unsafe.Coerce (unsafeCoerce)

liftB :: FixedPrim a -> BoundedPrim a
liftB :: forall a. FixedPrim a -> BoundedPrim a
liftB = forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded

digit   :: FixedPrim Int
digit :: FixedPrim Int
digit   = (\Int
x -> Int -> Char
chr (Int
x forall a. Num a => a -> a -> a
+ Int
48)) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Char
char8

digits2 :: FixedPrim Int
digits2 :: FixedPrim Int
digits2 = (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Int
digit forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digit)

digits3 :: FixedPrim Int
digits3 :: FixedPrim Int
digits3 = (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Int
digits2 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digit)

digits4 :: FixedPrim Int
digits4 :: FixedPrim Int
digits4 = (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Int
digits3 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digit)

frac :: BoundedPrim Int64
frac :: BoundedPrim Int64
frac = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int64
0) forall a. BoundedPrim a
emptyB ((,) Char
'.' forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int64
trunc12))
  where
    trunc12 :: BoundedPrim Int64
    trunc12 :: BoundedPrim Int64
trunc12 = (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
1000000) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
              forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (\(Int64
_,Int64
y) -> Int64
y forall a. Eq a => a -> a -> Bool
== Int64
0)
                    (forall a b. (a, b) -> a
fst forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Int64
trunc6)
                    (forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Int64
digits6 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int64
trunc6)

    digitB :: BoundedPrim Int
digitB  = forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Int
digit

    digits6 :: FixedPrim Int64
digits6 = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10)) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Int
digits5 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digit)
    digits5 :: FixedPrim Int
digits5 =                   (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10)  forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Int
digits4 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digit)

    trunc6 :: BoundedPrim Int64
trunc6 =    (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
100000)) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digitB forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc5)
    trunc5 :: BoundedPrim Int
trunc5 = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int
0) forall a. BoundedPrim a
emptyB ((forall a. Integral a => a -> a -> (a, a)
`quotRem`  Int
10000)  forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digitB forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc4))
    trunc4 :: BoundedPrim Int
trunc4 = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int
0) forall a. BoundedPrim a
emptyB ((forall a. Integral a => a -> a -> (a, a)
`quotRem`   Int
1000)  forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digitB forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc3))
    trunc3 :: BoundedPrim Int
trunc3 = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int
0) forall a. BoundedPrim a
emptyB ((forall a. Integral a => a -> a -> (a, a)
`quotRem`    Int
100)  forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digitB forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc2))
    trunc2 :: BoundedPrim Int
trunc2 = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int
0) forall a. BoundedPrim a
emptyB ((forall a. Integral a => a -> a -> (a, a)
`quotRem`     Int
10)  forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digitB forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc1))
    trunc1 :: BoundedPrim Int
trunc1 = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
== Int
0) forall a. BoundedPrim a
emptyB BoundedPrim Int
digitB


year  :: BoundedPrim Int32
year :: BoundedPrim Int32
year = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Ord a => a -> a -> Bool
>= Int32
10000) BoundedPrim Int32
int32Dec (Int32 -> Int
checkBCE forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Int
digits4)
  where
    checkBCE :: Int32 -> Int
    checkBCE :: Int32 -> Int
checkBCE Int32
y
        | Int32
y forall a. Ord a => a -> a -> Bool
> Int32
0     = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
y
        | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
msg

    msg :: [Char]
msg = [Char]
"Database.PostgreSQL.Simple.Time.Printer.year:  years BCE not supported"

day :: BoundedPrim Day
day :: BoundedPrim Day
day = forall {a}. Num a => Day -> (a, (Char, (Int, (Char, Int))))
toYMD forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int32
year forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< forall a. FixedPrim a -> BoundedPrim a
liftB (FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digits2 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digits2))
  where
    toYMD :: Day -> (a, (Char, (Int, (Char, Int))))
toYMD (Day -> (Integer, Int, Int)
toGregorian -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral -> !a
y, !Int
m,!Int
d)) = (a
y,(Char
'-',(Int
m,(Char
'-',Int
d))))

timeOfDay :: BoundedPrim TimeOfDay
timeOfDay :: BoundedPrim TimeOfDay
timeOfDay = TimeOfDay -> ((Int, (Char, (Int, Char))), Pico)
f forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim (Int, (Char, (Int, Char)))
hh_mm_ forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Pico
ss)
  where
    f :: TimeOfDay -> ((Int, (Char, (Int, Char))), Pico)
f (TimeOfDay Int
h Int
m Pico
s)  =  ((Int
h,(Char
':',(Int
m,Char
':'))),Pico
s)

    hh_mm_ :: BoundedPrim (Int, (Char, (Int, Char)))
hh_mm_ = forall a. FixedPrim a -> BoundedPrim a
liftB (FixedPrim Int
digits2 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digits2 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
char8)

    ss :: BoundedPrim Pico
ss = (\Pico
s -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pico -> Integer
fromPico Pico
s) forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
1000000000000) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
         (forall a. FixedPrim a -> BoundedPrim a
liftB (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Int
digits2) forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int64
frac)

timeZone :: BoundedPrim TimeZone
timeZone :: BoundedPrim TimeZone
timeZone = TimeZone -> Int
timeZoneMinutes forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Int
tz
  where
    tz :: BoundedPrim Int
tz  = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Ord a => a -> a -> Bool
>= Int
0) ((,) Char
'+' forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim (Char, Int)
tzh) ((,) Char
'-' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim (Char, Int)
tzh)

    tzh :: BoundedPrim (Char, Int)
tzh = forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< ((forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
60) forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Int
digits2 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
tzm))

    tzm :: BoundedPrim Int
tzm = forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (forall a. Eq a => a -> a -> Bool
==Int
0) forall a. BoundedPrim a
emptyB ((,) Char
':' forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< forall a. FixedPrim a -> BoundedPrim a
liftB (FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Int
digits2))

utcTime :: BoundedPrim UTCTime
utcTime :: BoundedPrim UTCTime
utcTime = UTCTime -> (Day, (Char, (TimeOfDay, Char)))
f forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Day
day forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim TimeOfDay
timeOfDay forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Char
char8)
  where f :: UTCTime -> (Day, (Char, (TimeOfDay, Char)))
f (UTCTime Day
d (DiffTime -> TimeOfDay
timeToTimeOfDay -> TimeOfDay
tod)) = (Day
d,(Char
' ',(TimeOfDay
tod,Char
'Z')))

localTime :: BoundedPrim LocalTime
localTime :: BoundedPrim LocalTime
localTime = LocalTime -> (Day, (Char, TimeOfDay))
f forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Day
day forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< forall a. FixedPrim a -> BoundedPrim a
liftB FixedPrim Char
char8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim TimeOfDay
timeOfDay)
  where f :: LocalTime -> (Day, (Char, TimeOfDay))
f (LocalTime Day
d TimeOfDay
tod) = (Day
d, (Char
' ', TimeOfDay
tod))

zonedTime :: BoundedPrim ZonedTime
zonedTime :: BoundedPrim ZonedTime
zonedTime = ZonedTime -> (LocalTime, TimeZone)
f forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim LocalTime
localTime forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim TimeZone
timeZone)
  where f :: ZonedTime -> (LocalTime, TimeZone)
f (ZonedTime LocalTime
lt TimeZone
tz) = (LocalTime
lt, TimeZone
tz)


nominalDiffTime :: NominalDiffTime -> Builder
nominalDiffTime :: NominalDiffTime -> Builder
nominalDiffTime NominalDiffTime
xy = Integer -> Builder
integerDec Integer
x forall a. Semigroup a => a -> a -> a
<> forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim Int64
frac (forall a. Num a => a -> a
abs (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y))
  where
    (Integer
x,Integer
y) = Pico -> Integer
fromPico (forall a b. a -> b
unsafeCoerce NominalDiffTime
xy) forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
1000000000000

calendarDiffTime :: CalendarDiffTime -> Builder
calendarDiffTime :: CalendarDiffTime -> Builder
calendarDiffTime = ByteString -> Builder
byteString
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString
    -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
    -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
    -- to ASCII output.
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. ISO8601 t => t -> [Char]
iso8601Show