{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE TupleSections              #-}

{-|
Module      : System.Random.Atmospheric.Api.DateTime
Description : Date and time format used by the RANDOM.ORG Core API (Release 4)
Copyright   : Copyright 2024 Mike Pilgrem (except as indicated)
License     : BSD-3-Clause
Maintainer  : public@pilgrem.com
Stability   : Experimental
Portability : Portable

The output of the [RANDOM.ORG](https://random.org) Core API (Release 4) uses a
date and time format that is allowed by RFC 3999 but not permitted by ISO 8601.

This module has no connection with Randomness and Integrity Services Limited or
its affilates or the RANDOM.ORG domain.
-}

module System.Random.Atmospheric.Api.DateTime
  ( DateTime (..)
  ) where

import           Data.Aeson.Encoding ( encodingToLazyByteString )
import           Data.Aeson.Encoding.Internal ( Encoding' (..) )
import           Data.Aeson.Types ( ToJSON (..), Value (..) )
import           Data.ByteString.Builder ( Builder, char7, char8, integerDec)
import           Data.ByteString.Builder.Prim
                   ( BoundedPrim, (>$<), (>*<), condB, emptyB
                   , liftFixedToBounded, primBounded
                   )
import qualified Data.ByteString.Builder.Prim as BP
import qualified Data.ByteString.Lazy as L
import           Data.Char ( chr )
import           Data.Int ( Int64 )
import           Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Time.Calendar ( Day, toGregorian )
import           Data.Time.Clock
                   ( DiffTime, UTCTime (..), diffTimeToPicoseconds )

-- | Type representing UTC date and times but with a different 'ToJSON'

-- instance that uses a version of ISO 8601 modified to use an alternative

-- allowed by RFC 3999.

newtype DateTime = DateTime
  { DateTime -> UTCTime
unDateTime :: UTCTime
  }

instance ToJSON DateTime where

  toJSON :: DateTime -> Value
toJSON  = Encoding' Text -> Value
stringEncoding (Encoding' Text -> Value)
-> (DateTime -> Encoding' Text) -> DateTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Encoding' Text
forall tag. Builder -> Encoding' tag
Encoding (Builder -> Encoding' Text)
-> (DateTime -> Builder) -> DateTime -> Encoding' Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
quote (Builder -> Builder)
-> (DateTime -> Builder) -> DateTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Builder
utcTime (UTCTime -> Builder)
-> (DateTime -> UTCTime) -> DateTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateTime -> UTCTime
unDateTime

  toEncoding :: DateTime -> Encoding
toEncoding = Builder -> Encoding
forall tag. Builder -> Encoding' tag
Encoding (Builder -> Encoding)
-> (DateTime -> Builder) -> DateTime -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
quote (Builder -> Builder)
-> (DateTime -> Builder) -> DateTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Builder
utcTime (UTCTime -> Builder)
-> (DateTime -> UTCTime) -> DateTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateTime -> UTCTime
unDateTime

-- | Modified version of ISO 8601 to use an alternative allowed by RFC 3999.

dayTime :: Day -> TimeOfDay64 -> Builder
dayTime :: Day -> TimeOfDay64 -> Builder
dayTime Day
d TimeOfDay64
t = Day -> Builder
day Day
d Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
delimiter Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TimeOfDay64 -> Builder
timeOfDay64 TimeOfDay64
t
 where
  delimiter :: Builder
delimiter = Char -> Builder
char7 Char
' '
  -- ISO 8601 requires the delimiter to be 'T' but RFC 3999 allows the

  -- delimiter to be ' '.

{-# INLINE dayTime #-}

--------------------------------------------------------------------------------

-- The following is based on module Data.Aeson.Encoding.Builder of the package

-- aeson-2.2.3.0, copyright 2011 MailRank, Inc. and 2013 Simon Meier.

--------------------------------------------------------------------------------


-- | Encode something to a JSON string.

stringEncoding :: Encoding' Text -> Value
stringEncoding :: Encoding' Text -> Value
stringEncoding = Text -> Value
String
  (Text -> Value)
-> (Encoding' Text -> Text) -> Encoding' Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropAround (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')
  (Text -> Text)
-> (Encoding' Text -> Text) -> Encoding' Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeLatin1
  (ByteString -> Text)
-> (Encoding' Text -> ByteString) -> Encoding' Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict
  (ByteString -> ByteString)
-> (Encoding' Text -> ByteString) -> Encoding' Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding' Text -> ByteString
forall a. Encoding' a -> ByteString
encodingToLazyByteString
{-# INLINE stringEncoding #-}

-- | Add quotes surrounding a builder

quote :: Builder -> Builder
quote :: Builder -> Builder
quote Builder
b = Char -> Builder
char8 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'"'

utcTime :: UTCTime -> Builder
utcTime :: UTCTime -> Builder
utcTime (UTCTime Day
d DiffTime
s) = Day -> TimeOfDay64 -> Builder
dayTime Day
d (DiffTime -> TimeOfDay64
diffTimeOfDay64 DiffTime
s) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'Z'
{-# INLINE utcTime #-}

day :: Day -> Builder
day :: Day -> Builder
day Day
dd =
     Integer -> Builder
encodeYear Integer
yr
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BoundedPrim () -> () -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded ((Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim ()
forall a.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
ascii6 (Char
'-', (Char
mh, (Char
ml, (Char
'-', (Char
dh, Char
dl)))))) ()
 where
  (Integer
yr,Int
m,Int
d)    = Day -> (Integer, Int, Int)
toGregorian Day
dd
  !(T Char
mh Char
ml)  = Int -> T
twoDigits Int
m
  !(T Char
dh Char
dl)  = Int -> T
twoDigits Int
d
{-# INLINE day #-}

-- | Used in encoding day, month, quarter

encodeYear :: Integer -> Builder
encodeYear :: Integer -> Builder
encodeYear Integer
y
  | Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1000 = Integer -> Builder
integerDec Integer
y
  | Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0    = BoundedPrim () -> () -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded ((Char, (Char, (Char, Char))) -> BoundedPrim ()
forall a. (Char, (Char, (Char, Char))) -> BoundedPrim a
ascii4 (Integer -> (Char, (Char, (Char, Char)))
forall {p}. Integral p => p -> (Char, (Char, (Char, Char)))
padYear Integer
y)) ()
  | Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
999 = BoundedPrim () -> () -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded ((Char, (Char, (Char, (Char, Char)))) -> BoundedPrim ()
forall a. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
ascii5 (Char
'-', Integer -> (Char, (Char, (Char, Char)))
forall {p}. Integral p => p -> (Char, (Char, (Char, Char)))
padYear (- Integer
y))) ()
  | Bool
otherwise = Integer -> Builder
integerDec Integer
y
 where
  padYear :: p -> (Char, (Char, (Char, Char)))
padYear p
y' =
      let (Int
ab, Int
c) = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
y' 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  (Char
'0', (Int -> Char
digit Int
a, (Int -> Char
digit Int
b, Int -> Char
digit Int
c)))
{-# INLINE encodeYear #-}

ascii4 :: (Char, (Char, (Char, Char))) -> BoundedPrim a
ascii4 :: forall a. (Char, (Char, (Char, Char))) -> BoundedPrim a
ascii4 (Char, (Char, (Char, Char)))
cs = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, Char))) -> a -> (Char, (Char, (Char, Char)))
forall a b. a -> b -> a
const (Char, (Char, (Char, Char)))
cs (a -> (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, Char))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
  FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7
{-# INLINE ascii4 #-}

ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
ascii5 :: forall a. (Char, (Char, (Char, (Char, Char)))) -> BoundedPrim a
ascii5 (Char, (Char, (Char, (Char, Char))))
cs = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, Char))))
-> a -> (Char, (Char, (Char, (Char, Char))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, Char))))
cs (a -> (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim (Char, (Char, (Char, (Char, Char)))) -> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
  FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7
{-# INLINE ascii5 #-}

ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
ascii6 :: forall a.
(Char, (Char, (Char, (Char, (Char, Char))))) -> BoundedPrim a
ascii6 (Char, (Char, (Char, (Char, (Char, Char)))))
cs = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, (Char, Char)))))
-> a -> (Char, (Char, (Char, (Char, (Char, Char)))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, Char)))))
cs (a -> (Char, (Char, (Char, (Char, (Char, Char))))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
  FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7
{-# INLINE ascii6 #-}

ascii8 ::
     (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
  -> BoundedPrim a
ascii8 :: forall a.
(Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
-> BoundedPrim a
ascii8 (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
cs = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (FixedPrim a -> BoundedPrim a) -> FixedPrim a -> BoundedPrim a
forall a b. (a -> b) -> a -> b
$ (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
-> a
-> (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
forall a b. a -> b -> a
const (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
cs (a -> (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char))))))))
-> FixedPrim
     (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
-> FixedPrim a
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
  FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, (Char, (Char, Char))))))
-> FixedPrim
     (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, (Char, Char))))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
-> FixedPrim (Char, (Char, (Char, (Char, (Char, Char)))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, (Char, Char)))
-> FixedPrim (Char, (Char, (Char, (Char, Char))))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, (Char, Char))
-> FixedPrim (Char, (Char, (Char, Char)))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7 FixedPrim Char
-> FixedPrim (Char, Char) -> FixedPrim (Char, (Char, Char))
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*<
  FixedPrim Char
BP.char7 FixedPrim Char -> FixedPrim Char -> FixedPrim (Char, Char)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< FixedPrim Char
BP.char7
{-# INLINE ascii8 #-}

twoDigits :: Int -> T
twoDigits :: Int -> T
twoDigits Int
a = Char -> Char -> T
T (Int -> Char
digit Int
hi) (Int -> Char
digit Int
lo)
 where
  (Int
hi, Int
lo) = Int
a Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10

digit :: Int -> Char
digit :: Int -> Char
digit Int
x = Int -> Char
chr (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
48)

data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char

timeOfDay64 :: TimeOfDay64 -> Builder
timeOfDay64 :: TimeOfDay64 -> Builder
timeOfDay64 (TOD Int
h Int
m Int64
s)
  | Int64
frac Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 = Builder
hhmmss -- omit subseconds if 0

  | Bool
otherwise = Builder
hhmmss Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BoundedPrim Int64 -> Int64 -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim Int64
showFrac Int64
frac
 where
  hhmmss :: Builder
hhmmss =
    BoundedPrim () -> () -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded ((Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
-> BoundedPrim ()
forall a.
(Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
-> BoundedPrim a
ascii8 (Char
hh, (Char
hl, (Char
':', (Char
mh, (Char
ml, (Char
':', (Char
sh, Char
sl)))))))) ()
  !(T Char
hh Char
hl)  = Int -> T
twoDigits Int
h
  !(T Char
mh Char
ml)  = Int -> T
twoDigits Int
m
  !(T Char
sh Char
sl)  = Int -> T
twoDigits (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
real)
  (Int64
real,Int64
frac) = Int64
s Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
pico
  showFrac :: BoundedPrim Int64
showFrac = (Char
'.',) (Int64 -> (Char, Int64))
-> BoundedPrim (Char, Int64) -> BoundedPrim Int64
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (FixedPrim Char -> BoundedPrim Char
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded FixedPrim Char
BP.char7 BoundedPrim Char -> BoundedPrim Int64 -> BoundedPrim (Char, Int64)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int64
trunc12)
  trunc12 :: BoundedPrim Int64
trunc12 = (Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
micro) (Int64 -> (Int64, Int64))
-> BoundedPrim (Int64, Int64) -> BoundedPrim Int64
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
            ((Int64, Int64) -> Bool)
-> BoundedPrim (Int64, Int64)
-> BoundedPrim (Int64, Int64)
-> BoundedPrim (Int64, Int64)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (\(Int64
_, Int64
y) -> Int64
y Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) ((Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst ((Int64, Int64) -> Int64)
-> BoundedPrim Int64 -> BoundedPrim (Int64, Int64)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Int64
trunc6) (BoundedPrim Int64
digits6 BoundedPrim Int64
-> BoundedPrim Int64 -> BoundedPrim (Int64, Int64)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int64
trunc6)
  digits6 :: BoundedPrim Int64
digits6 = ((Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
milli) (Int -> (Int, Int)) -> (Int64 -> Int) -> Int64 -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Int64 -> (Int, Int))
-> BoundedPrim (Int, Int) -> BoundedPrim Int64
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digits3 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
digits3)
  trunc6 :: BoundedPrim Int64
trunc6  = ((Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
milli) (Int -> (Int, Int)) -> (Int64 -> Int) -> Int64 -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Int64 -> (Int, Int))
-> BoundedPrim (Int, Int) -> BoundedPrim Int64
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$<
            ((Int, Int) -> Bool)
-> BoundedPrim (Int, Int)
-> BoundedPrim (Int, Int)
-> BoundedPrim (Int, Int)
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (\(Int
_, Int
y) -> Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< BoundedPrim Int
trunc3) (BoundedPrim Int
digits3 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc3)
  digits3 :: BoundedPrim Int
digits3 = (Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10) (Int -> (Int, Int)) -> BoundedPrim (Int, Int) -> BoundedPrim Int
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digits2 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
digits1)
  digits2 :: BoundedPrim Int
digits2 = (Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10) (Int -> (Int, Int)) -> BoundedPrim (Int, Int) -> BoundedPrim Int
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digits1 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
digits1)
  digits1 :: BoundedPrim Int
digits1 = FixedPrim Int -> BoundedPrim Int
forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded (Int -> Char
digit (Int -> Char) -> FixedPrim Char -> FixedPrim Int
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< FixedPrim Char
BP.char7)
  trunc3 :: BoundedPrim Int
trunc3  = (Int -> Bool)
-> BoundedPrim Int -> BoundedPrim Int -> BoundedPrim Int
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) BoundedPrim Int
forall a. BoundedPrim a
emptyB (BoundedPrim Int -> BoundedPrim Int)
-> BoundedPrim Int -> BoundedPrim Int
forall a b. (a -> b) -> a -> b
$
            (Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
100) (Int -> (Int, Int)) -> BoundedPrim (Int, Int) -> BoundedPrim Int
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digits1 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc2)
  trunc2 :: BoundedPrim Int
trunc2  = (Int -> Bool)
-> BoundedPrim Int -> BoundedPrim Int -> BoundedPrim Int
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) BoundedPrim Int
forall a. BoundedPrim a
emptyB (BoundedPrim Int -> BoundedPrim Int)
-> BoundedPrim Int -> BoundedPrim Int
forall a b. (a -> b) -> a -> b
$
            (Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
10)  (Int -> (Int, Int)) -> BoundedPrim (Int, Int) -> BoundedPrim Int
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
>$< (BoundedPrim Int
digits1 BoundedPrim Int -> BoundedPrim Int -> BoundedPrim (Int, Int)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< BoundedPrim Int
trunc1)
  trunc1 :: BoundedPrim Int
trunc1  = (Int -> Bool)
-> BoundedPrim Int -> BoundedPrim Int -> BoundedPrim Int
forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) BoundedPrim Int
forall a. BoundedPrim a
emptyB BoundedPrim Int
digits1

  pico :: Int64
pico       = Int64
1000000000000 -- number of picoseconds  in 1 second

  micro :: Int64
micro      =       Int64
1000000 -- number of microseconds in 1 second

  milli :: Int
milli      =          Int
1000 -- number of milliseconds in 1 second


data TimeOfDay64 = TOD {-# UNPACK #-} !Int
                       {-# UNPACK #-} !Int
                       {-# UNPACK #-} !Int64

posixDayLength :: DiffTime
posixDayLength :: DiffTime
posixDayLength = DiffTime
86400

diffTimeOfDay64 :: DiffTime -> TimeOfDay64
diffTimeOfDay64 :: DiffTime -> TimeOfDay64
diffTimeOfDay64 DiffTime
t
  | DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
posixDayLength = Int -> Int -> Int64 -> TimeOfDay64
TOD Int
23 Int
59 (Int64
60000000000000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ DiffTime -> Int64
pico (DiffTime
t DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
posixDayLength))
  | Bool
otherwise = Int -> Int -> Int64 -> TimeOfDay64
TOD (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
h) (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
m) Int64
s
 where
  (Int64
h, Int64
mp) = DiffTime -> Int64
pico DiffTime
t Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
3600000000000000
  (Int64
m, Int64
s)  = Int64
mp Int64 -> Int64 -> (Int64, Int64)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int64
60000000000000
  pico :: DiffTime -> Int64
pico   = Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> (DiffTime -> Integer) -> DiffTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds