2019-05-08 21:47:20 +03:00
|
|
|
{-# LANGUAGE NumericUnderscores, GeneralizedNewtypeDeriving #-}
|
|
|
|
|
2019-05-08 23:00:12 +03:00
|
|
|
-- TODO This is slow.
|
|
|
|
|
2019-05-08 21:47:20 +03:00
|
|
|
module Urbit.Time where
|
|
|
|
|
|
|
|
import Prelude
|
|
|
|
import Control.Lens
|
|
|
|
|
|
|
|
import Data.Coerce (coerce)
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
|
|
import Control.Exception (throw, ArithException(Underflow))
|
|
|
|
import Data.Bits (shiftL, shiftR)
|
|
|
|
import Data.LargeWord (Word128, LargeKey(..))
|
|
|
|
import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime,
|
|
|
|
diffTimeToPicoseconds)
|
|
|
|
import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime,
|
|
|
|
systemToUTCTime)
|
|
|
|
|
|
|
|
|
|
|
|
-- Types -----------------------------------------------------------------------
|
|
|
|
|
|
|
|
newtype Gap = Gap { unGap :: Word128 }
|
|
|
|
deriving (Eq, Ord, Show)
|
|
|
|
|
|
|
|
newtype Wen = Wen { unWen :: Word128 }
|
|
|
|
deriving (Eq, Ord, Show)
|
|
|
|
|
|
|
|
newtype Unix = Unix { unUnix :: Word128 }
|
|
|
|
deriving (Eq, Ord, Show)
|
|
|
|
|
|
|
|
|
|
|
|
-- Basic Lenses ----------------------------------------------------------------
|
|
|
|
|
|
|
|
fractoSecs :: Iso' Gap Word128
|
|
|
|
fractoSecs = iso unGap Gap
|
|
|
|
|
|
|
|
sinceUrbitEpoch :: Iso' Wen Gap
|
|
|
|
sinceUrbitEpoch = iso (Gap . unWen) (Wen . unGap)
|
|
|
|
|
|
|
|
sinceUnixEpoch :: Iso' Unix Gap
|
|
|
|
sinceUnixEpoch = iso (Gap . unUnix) (Unix . unGap)
|
|
|
|
|
|
|
|
|
|
|
|
-- Instances -------------------------------------------------------------------
|
|
|
|
|
|
|
|
instance Num Gap where
|
|
|
|
x + y = Gap (coerce x + coerce y)
|
|
|
|
x * y = Gap (coerce x * coerce y)
|
|
|
|
fromInteger = Gap . fromInteger
|
|
|
|
abs = over fractoSecs abs
|
|
|
|
signum = over fractoSecs signum
|
|
|
|
negate = over fractoSecs negate
|
|
|
|
|
|
|
|
|
|
|
|
-- Conversions -----------------------------------------------------------------
|
|
|
|
|
|
|
|
diffTime :: Iso' Gap DiffTime
|
|
|
|
diffTime = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap = picosecondsToDiffTime . view picoSecs
|
|
|
|
toGap = view (from picoSecs) . diffTimeToPicoseconds
|
|
|
|
|
|
|
|
utcTime :: Iso' Unix UTCTime
|
|
|
|
utcTime = iso fromUnix toUnix
|
|
|
|
where
|
|
|
|
fromUnix = systemToUTCTime . view systemTime
|
|
|
|
toUnix = view (from systemTime) . utcToSystemTime
|
|
|
|
|
|
|
|
wenUtcTime :: Iso' Wen UTCTime
|
|
|
|
wenUtcTime = unix . utcTime
|
|
|
|
|
|
|
|
systemTime :: Iso' Unix SystemTime
|
|
|
|
systemTime = iso toSys fromSys
|
|
|
|
where
|
|
|
|
toSys :: Unix -> SystemTime
|
|
|
|
toSys (sinceUnixEpoch -> gap) =
|
|
|
|
MkSystemTime (gap ^. secs) (gap ^. nanoSecs `mod` 1_000_000_000)
|
|
|
|
|
|
|
|
fromSys :: SystemTime -> Unix
|
|
|
|
fromSys (MkSystemTime numSecs ns) =
|
|
|
|
fromUnixEpoch $ (numSecs ^. from secs) + (ns ^. from nanoSecs)
|
|
|
|
|
|
|
|
fromUnixEpoch :: Gap -> Unix
|
|
|
|
fromUnixEpoch (Gap g) = Unix g
|
|
|
|
|
|
|
|
sinceUnixEpoch :: Unix -> Gap
|
|
|
|
sinceUnixEpoch (Unix u) = Gap u
|
|
|
|
|
|
|
|
unixEpoch :: Wen
|
|
|
|
unixEpoch = Wen (LargeKey 0x8000_000c_ce9e_0d80 0)
|
|
|
|
|
|
|
|
unix :: Iso' Wen Unix
|
|
|
|
unix = iso toUnix fromUnix
|
|
|
|
where
|
|
|
|
fromUnix (Unix u) = Wen (u + epoch)
|
|
|
|
toUnix (Wen w) | w >= epoch = Unix (w - epoch)
|
|
|
|
| otherwise = throw Underflow
|
|
|
|
epoch = view (sinceUrbitEpoch . fractoSecs) unixEpoch
|
|
|
|
|
|
|
|
picoSecs :: (Integral a, Num a) => Iso' Gap a
|
|
|
|
picoSecs = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000_000) 64)
|
|
|
|
toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000_000)
|
|
|
|
|
|
|
|
nanoSecs :: (Integral a, Num a) => Iso' Gap a
|
|
|
|
nanoSecs = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000) 64)
|
|
|
|
toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000)
|
|
|
|
|
|
|
|
microSecs :: (Integral a, Num a) => Iso' Gap a
|
|
|
|
microSecs = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000) 64)
|
|
|
|
toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000)
|
|
|
|
|
|
|
|
milliSecs :: (Integral a, Num a) => Iso' Gap a
|
|
|
|
milliSecs = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap (Gap x) = fromIntegral (shiftR (x * 1_000) 64)
|
|
|
|
toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000)
|
|
|
|
|
|
|
|
secs :: (Integral a, Num a) => Iso' Gap a
|
|
|
|
secs = iso fromGap toGap
|
|
|
|
where
|
|
|
|
fromGap (Gap x) = fromIntegral (shiftR x 64)
|
|
|
|
toGap x = Gap (shiftL (fromIntegral x) 64)
|
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
now :: IO Wen
|
|
|
|
now = view (from systemTime . from unix) <$> getSystemTime
|
|
|
|
|
|
|
|
gap :: Wen -> Wen -> Gap
|
|
|
|
gap (Wen x) (Wen y) | x > y = Gap (x - y)
|
|
|
|
| otherwise = Gap (y - x)
|
|
|
|
|
|
|
|
addGap :: Wen -> Gap -> Wen
|
|
|
|
addGap (Wen fs) (Gap g) = Wen (fs + g)
|
|
|
|
|
|
|
|
sleep :: Gap -> IO ()
|
2019-05-08 23:51:04 +03:00
|
|
|
sleep gap = do threadDelay (gap ^. microSecs)
|
2019-05-08 21:47:20 +03:00
|
|
|
|
|
|
|
sleepUntil :: Wen -> IO ()
|
|
|
|
sleepUntil end = do
|
|
|
|
now >>= \case
|
|
|
|
start | start >= end -> pure ()
|
|
|
|
| otherwise -> sleep (gap start end)
|