urbit/pkg/hair/lib/Urbit/Time.hs

152 lines
4.5 KiB
Haskell
Raw Normal View History

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)