Urbit.Time

pkg/hs/vere/Main.hs

@@ -0,0 +1,56 @@
+module Main where
+
+import Prelude
+import Control.Lens
+
+import Data.LargeWord (Word128, LargeKey(..))
+
+import qualified Urbit.Behn as Behn
+import qualified Urbit.Time as Time
+
+--------------------------------------------------------------------------------
+
+bench :: Behn.Behn -> IO (Time.Wen, Time.Wen, Time.Wen)
+bench behn = do
+  now  <- Time.now
+
+  print (now ^. Time.wenUtcTime)
+
+  Behn.doze behn (Just (Time.addGap now (500 ^. from Time.milliSecs)))
+
+  wen <- Behn.wait behn
+  aft <- Time.now
+
+  pure (now, wen, aft)
+
+main :: IO ()
+main = do
+  behn <- Behn.init
+
+  (x1,y1,z1) <- bench behn
+  (x2,y2,z2) <- bench behn
+  (x3,y3,z3) <- bench behn
+
+  putStrLn "----"
+
+  print (x1 ^. Time.wenUtcTime)
+  print (Time.gap x1 y1 ^. Time.milliSecs)
+  print (y1 ^. Time.wenUtcTime)
+  print (Time.gap y1 z1 ^. Time.milliSecs)
+  print (z1 ^. Time.wenUtcTime)
+
+  putStrLn "----"
+
+  print (x2 ^. Time.wenUtcTime)
+  print (Time.gap x2 y2 ^. Time.milliSecs)
+  print (y2 ^. Time.wenUtcTime)
+  print (Time.gap y2 z2 ^. Time.milliSecs)
+  print (z2 ^. Time.wenUtcTime)
+
+  putStrLn "----"
+
+  print (x3 ^. Time.wenUtcTime)
+  print (Time.gap x3 y3 ^. Time.milliSecs)
+  print (y3 ^. Time.wenUtcTime)
+  print (Time.gap y3 z3 ^. Time.milliSecs)
+  print (z3 ^. Time.wenUtcTime)

pkg/hs/vere/Urbit/Behn.hs

@@ -34,50 +34,29 @@
     to return) first, and then `doze` action will wait until that finishes.
 -}
 
-module Vere.Behn (Behn, init, wait, doze) where
+module Urbit.Behn (Behn, init, wait, doze) where
+
+import Prelude hiding (init)
+import Control.Lens
 
-import Control.Concurrent
-import Control.Concurrent.Async hiding (wait)
-import Control.Concurrent.MVar
 import Data.LargeWord
-import Prelude                  hiding (init)
+import Control.Concurrent.MVar
 
-import Data.Time.Clock.System (SystemTime(..), getSystemTime)
-import Control.Lens  ((&))
-import Control.Monad (void)
+import Control.Concurrent.Async (Async, async, cancel, asyncThreadId)
+import Control.Concurrent       (threadDelay, killThread)
+import Control.Monad            (void)
+import Data.Time.Clock.System   (SystemTime(..), getSystemTime)
+import Urbit.Time               (Wen)
 
+import qualified Control.Concurrent.Async as Async
+import qualified Urbit.Time               as Time
 
--- Time Stuff ------------------------------------------------------------------
-
-type UrbitTime = Word128
-
-urNow :: IO UrbitTime
-urNow = systemTimeToUrbitTime <$> getSystemTime
-
-{-
-    TODO This is wrong.
-
-    - The high word should be `(0x8000000cce9e0d80ULL + secs)`
-    - The low word should be `(((usecs * 65536ULL) / 1000000ULL) << 48ULL)`
--}
-systemTimeToUrbitTime :: SystemTime -> UrbitTime
-systemTimeToUrbitTime (MkSystemTime secs ns) =
-  LargeKey (fromIntegral secs) (fromIntegral ns)
-
--- TODO
-urbitTimeToMicrosecs :: UrbitTime -> Int
-urbitTimeToMicrosecs x = fromIntegral x
-
--- TODO Double Check this
-diffTime :: UrbitTime -> UrbitTime -> UrbitTime
-diffTime fst snd | fst >= snd = 0
-                 | otherwise  = snd - fst
 
 -- Behn Stuff ------------------------------------------------------------------
 
 data Behn = Behn
-  { bState  :: MVar (Maybe (UrbitTime, Async ()))
-  , bSignal :: MVar UrbitTime
+  { bState  :: MVar (Maybe (Wen, Async ()))
+  , bSignal :: MVar Wen
   }
 
 init :: IO Behn
@@ -86,23 +65,25 @@ init = do
   sig <- newEmptyMVar
   pure (Behn st sig)
 
-wait :: Behn -> IO UrbitTime
+wait :: Behn -> IO Wen
 wait (Behn _ sig) = takeMVar sig
 
-startTimerThread :: Behn -> UrbitTime -> IO (Async ())
+startTimerThread :: Behn -> Wen -> IO (Async ())
 startTimerThread (Behn vSt sig) time =
   async $ do
-    now <- urNow
-    threadDelay (urbitTimeToMicrosecs (now `diffTime` time))
-    void (swapMVar vSt Nothing >> tryPutMVar sig time)
+    now <- Time.now
+    threadDelay (Time.gap now time ^. Time.microSecs)
+    takeMVar vSt
+    void $ tryPutMVar sig time
+    putMVar vSt Nothing
 
-doze :: Behn -> Maybe UrbitTime -> IO ()
+doze :: Behn -> Maybe Wen -> IO ()
 doze behn@(Behn vSt sig) mNewTime = do
   takeMVar vSt >>= \case Nothing        -> pure ()
                          Just (_,timer) -> cancel timer
 
   newSt <- mNewTime & \case
-    Nothing   -> pure (Nothing :: Maybe (UrbitTime, Async ()))
+    Nothing   -> pure (Nothing :: Maybe (Wen, Async ()))
     Just time -> do timer <- startTimerThread behn time
                     pure (Just (time, timer))
 

pkg/hs/vere/Urbit/Time.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE NumericUnderscores, GeneralizedNewtypeDeriving #-}
+
+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 ()
+sleep gap = threadDelay (gap ^. microSecs)
+
+sleepUntil :: Wen -> IO ()
+sleepUntil end = do
+  now >>= \case
+    start | start >= end -> pure ()
+          | otherwise    -> sleep (gap start end)

pkg/hs/vere/package.yaml

@@ -3,17 +3,17 @@ version: 0.1.0
 license: AGPL-3.0-only
 
 default-extensions:
- - OverloadedStrings
- - TypeApplications
- - UnicodeSyntax
+ - DeriveGeneric
  - FlexibleContexts
- - TemplateHaskell
- - QuasiQuotes
  - LambdaCase
  - NoImplicitPrelude
+ - OverloadedStrings
+ - QuasiQuotes
  - ScopedTypeVariables
- - DeriveAnyClass
- - DeriveGeneric
+ - TemplateHaskell
+ - TypeApplications
+ - UnicodeSyntax
+ - ViewPatterns
 
 dependencies:
  - base
@@ -25,5 +25,9 @@ dependencies:
  - largeword
  - time
 
-library:
-  source-dirs: .
+executables:
+  vere:
+    main: Main.hs
+    source-dirs: .
+    ghc-options:
+      - -threaded