{-# 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
    ) where

import Control.Arrow ((>>>))
import Data.ByteString.Builder (Builder, 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.Time
    ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
    , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
    , TimeZone, timeZoneMinutes )
import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
import Unsafe.Coerce (unsafeCoerce)

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

digit   :: FixedPrim Int
digit   = (\x -> chr (x + 48)) >$< char8

digits2 :: FixedPrim Int
digits2 = (`quotRem` 10) >$< (digit >*< digit)

digits3 :: FixedPrim Int
digits3 = (`quotRem` 10) >$< (digits2 >*< digit)

digits4 :: FixedPrim Int
digits4 = (`quotRem` 10) >$< (digits3 >*< digit)

frac :: BoundedPrim Int64
frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
  where
    trunc12 :: BoundedPrim Int64
    trunc12 = (`quotRem` 1000000) >$<
              condB (\(_,y) -> y == 0)
                    (fst >$< trunc6)
                    (liftB digits6 >*< trunc6)

    digitB  = liftB digit

    digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)
    digits5 =                   (`quotRem` 10)  >$< (digits4 >*< digit)

    trunc6 =    (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)
    trunc5 = condB (== 0) emptyB ((`quotRem`  10000)  >$< (digitB >*< trunc4))
    trunc4 = condB (== 0) emptyB ((`quotRem`   1000)  >$< (digitB >*< trunc3))
    trunc3 = condB (== 0) emptyB ((`quotRem`    100)  >$< (digitB >*< trunc2))
    trunc2 = condB (== 0) emptyB ((`quotRem`     10)  >$< (digitB >*< trunc1))
    trunc1 = condB (== 0) emptyB digitB


year  :: BoundedPrim Int32
year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
  where
    checkBCE :: Int32 -> Int
    checkBCE y
        | y > 0     = fromIntegral y
        | otherwise = error msg

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

day :: BoundedPrim Day
day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))
  where
    toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))

timeOfDay :: BoundedPrim TimeOfDay
timeOfDay = f >$< (hh_mm_ >*< ss)
  where
    f (TimeOfDay h m s)  =  ((h,(':',(m,':'))),s)

    hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)

    ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<
         (liftB (fromIntegral >$< digits2) >*< frac)

timeZone :: BoundedPrim TimeZone
timeZone = timeZoneMinutes >$< tz
  where
    tz  = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)

    tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))

    tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))

utcTime :: BoundedPrim UTCTime
utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
  where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))

localTime :: BoundedPrim LocalTime
localTime = f >$< (day >*< liftB char8 >*< timeOfDay)
  where f (LocalTime d tod) = (d, (' ', tod))

zonedTime :: BoundedPrim ZonedTime
zonedTime = f >$< (localTime >*< timeZone)
  where f (ZonedTime lt tz) = (lt, tz)


nominalDiffTime :: NominalDiffTime -> Builder
nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
  where
    (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000