{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Connection.Time (
sysixx,
f32sys,
f64sys,
ratsys,
f09sys,
diffSystemTime,
getSystemTime,
SystemTime (..),
) where
import safe Data.Connection.Conn
import safe Data.Connection.Fixed
import safe Data.Connection.Ratio
import safe Data.Int
import safe Data.Order.Syntax
import safe Data.Time.Clock.System
import safe Prelude hiding (Eq (..), Ord (..), ceiling)
sysixx :: Conn k SystemTime Int
sysixx = Conn f g h
where
f (normalize -> MkSystemTime s n) = fromIntegral s + if n == 0 then 0 else 1
g i = MkSystemTime (fromIntegral i) 0
h (normalize -> MkSystemTime s _) = fromIntegral s
f32sys :: Conn 'L Float (Extended SystemTime)
f32sys = connL ratf32 >>> ratsys
f64sys :: Conn 'L Double (Extended SystemTime)
f64sys = connL ratf64 >>> ratsys
ratsys :: Conn k Rational (Extended SystemTime)
ratsys = ratfix >>> f09sys
f09sys :: Conn k (Extended Nano) (Extended SystemTime)
f09sys = Conn f g h
where
f NegInf = NegInf
f (Finite i) = extend (const False) (> max64) (fromNanoSecs . clamp) i
f PosInf = PosInf
g = fmap toNanoSecs
h NegInf = NegInf
h (Finite i) = extend (< min64) (const False) (fromNanoSecs . clamp) i
h PosInf = PosInf
min64 = - 2 ^ 63
max64 = 2 ^ 63 - 1
clamp = max min64 . min max64
diffSystemTime :: SystemTime -> SystemTime -> Double
diffSystemTime x y = inner f64sys $ round2 ratsys (-) (Finite x) (Finite y)
s2ns :: Num a => a
s2ns = 10 ^ 9
toNanoSecs :: SystemTime -> Nano
toNanoSecs (MkSystemTime (toInteger -> s) (toInteger -> n)) = MkFixed (s * s2ns + n)
fromNanoSecs :: Nano -> SystemTime
fromNanoSecs (MkFixed i) = MkSystemTime (fromInteger $ q) (fromInteger r)
where
(q, r) = divMod i s2ns
normalize :: SystemTime -> SystemTime
normalize (MkSystemTime xs xn)
| xn >= s2ns = MkSystemTime (xs + q) (fromIntegral r)
| otherwise = MkSystemTime xs xn
where
(q, r) = fromIntegral xn `divMod` s2ns