Add appStartTs to WidgetEnv. Make Timestamp a newtype (#103)

* Add _weAppStartTs to WidgetEnv, indicating the time in ms when the application started

* Use Timestamp type instead of Int to make signatures clearer

* Retrieve correct startup timestamp

* Use newtype instead of type for Timestamp

* Update Changelog

* Add utility function currentTimeMs, returning the absolute current timestamp (not from app start)

* Use currentTimeMs in examples

* Replace SDL.ticks call with utcTimeToPOSIXSeconds

* Restore nodeKey of description field in Tutorial 03

ChangeLog.md

@@ -12,6 +12,7 @@
 - Support for breaking text lines at character boundaries ([PR #86](https://github.com/fjvallarino/monomer/pull/86)). Thanks @toku-sa-n!
 - Read-only mode for `textField`, `numericField`, `dateField`, `timeField` and `textArea` ([PR #93](https://github.com/fjvallarino/monomer/pull/93)). Thanks @Dretch!
 - The `scroll` widget now supports a `thumbMinSize` configuration option that allows setting a minimum thumb size ([PR #100](https://github.com/fjvallarino/monomer/pull/100)).
+- New field `_weAppStartTs` in `WidgetEnv`, complementary to `_weTimestamp`, representing the time in milliseconds when the application started. Added utility function `currentTimeMs` that returns their sum with a polymorphic type ([PR #103](https://github.com/fjvallarino/monomer/pull/103)).
 
 ### Changed
 
@@ -21,6 +22,7 @@
   in `handleEvent` to know when the model changed. Widgets that want to report model changes to its parent can
   use `Report`/`RequestParent`; an example can be found in `ColorPicker` ([PR #71](https://github.com/fjvallarino/monomer/pull/71)).
 - The `keystroke` widget now supports the `Backspace` key ([PR #74](https://github.com/fjvallarino/monomer/pull/74)).
+- `Timestamp` is now a newtype. Enforce use of this type instead of `Int` when appropriate ([PR #103](https://github.com/fjvallarino/monomer/pull/103)).
 
 ### Renamed
 

examples/todo/Main.hs

@@ -221,7 +221,7 @@ handleEvent wenv node model evt = case evt of
 addNewTodo :: WidgetEnv s e -> TodoModel -> TodoModel
 addNewTodo wenv model = newModel where
   newTodo = model ^. activeTodo
-    & todoId .~ wenv ^. L.timestamp
+    & todoId .~ currentTimeMs wenv
   newModel = model
     & todos .~ (newTodo : model ^. todos)
 

examples/todo/TodoTypes.hs

@@ -31,7 +31,7 @@ data TodoStatus
   deriving (Eq, Show, Enum)
 
 data Todo = Todo {
-  _todoId :: Int,
+  _todoId :: Timestamp,
   _todoType :: TodoType,
   _status :: TodoStatus,
   _description :: Text

examples/tutorial/Tutorial03_LifeCycle.hs

@@ -22,7 +22,7 @@ import qualified Data.Text as T
 import qualified Monomer.Lens as L
 
 data ListItem = ListItem {
-  _ts :: Int,
+  _ts :: Timestamp,
   _text :: Text
 } deriving (Eq, Show)
 
@@ -59,7 +59,8 @@ buildUI wenv model = widgetTree where
       keystroke [("Enter", AddItem)] $ hstack [
         label "Description:",
         spacer,
-        textField_ newItemText [placeholder "Write here!"], -- `nodeKey` "description",
+        textField_ newItemText [placeholder "Write here!"]
+          `nodeKey` "description",
         spacer,
         button "Add" AddItem
           `styleBasic` [paddingH 5]
@@ -89,7 +90,7 @@ handleEvent wenv node model evt = case evt of
     & items .~ removeIdx idx (model ^. items)]
   _ -> []
   where
-    newItem = ListItem (wenv ^. L.timestamp) (model ^. newItemText)
+    newItem = ListItem (currentTimeMs wenv) (model ^. newItemText)
 
 removeIdx :: Int -> [a] -> [a]
 removeIdx idx lst = part1 ++ drop 1 part2 where

src/Monomer/Core/Util.hs

@@ -333,6 +333,14 @@ isResizeAnyResult res = isResizeResult res || isResizeImmediateResult res
 isMacOS :: WidgetEnv s e -> Bool
 isMacOS wenv = _weOs wenv == "Mac OS X"
 
+{-|
+Returns the current time in milliseconds. Adds appStartTs and timestamp fields
+from 'WidgetEnv' and converts the result to the expected 'Integral' type.
+-}
+currentTimeMs :: Integral a => WidgetEnv s e -> a
+currentTimeMs wenv = fromIntegral ts where
+  ts = wenv ^. L.appStartTs + wenv ^. L.timestamp
+
 -- | Returns a string description of a node and its children.
 widgetTreeDesc :: Int -> WidgetNode s e -> String
 widgetTreeDesc level node = desc where

src/Monomer/Core/WidgetTypes.hs

@@ -11,6 +11,7 @@ Basic types and definitions for Widgets.
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# Language GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE Strict #-}
 
@@ -24,7 +25,9 @@ import Data.Sequence (Seq)
 import Data.String (IsString(..))
 import Data.Text (Text)
 import Data.Typeable (Typeable, typeOf)
+import Data.Word (Word64)
 import GHC.Generics
+import TextShow
 
 import qualified Data.Text as T
 
@@ -34,8 +37,15 @@ import Monomer.Core.ThemeTypes
 import Monomer.Event.Types
 import Monomer.Graphics.Types
 
--- | Time ellapsed since startup
-type Timestamp = Int
+{-|
+Timestamp in milliseconds. Useful for representing the time of events, ellapsed
+time since start/start time of the application and length of intervals.
+
+It can be converted from/to other numeric types using the standard functions.
+-}
+newtype Timestamp = Timestamp {
+  unTimestamp :: Word64
+} deriving (Show, Eq, Ord, Num, Enum, Bounded, Real, Integral, TextShow)
 
 -- | Type constraints for a valid model
 type WidgetModel s = Typeable s
@@ -94,8 +104,8 @@ Several WidgetRequests rely on this to find the destination of asynchronous
 requests (tasks, clipboard, etc).
 -}
 data WidgetId = WidgetId {
-  _widTs :: Int,    -- ^ The timestamp when the instance was created.
-  _widPath :: Path  -- ^ The path at creation time.
+  _widTs :: Timestamp,  -- ^ The timestamp when the instance was created.
+  _widPath :: Path      -- ^ The path at creation time.
 } deriving (Eq, Show, Ord, Generic)
 
 instance Default WidgetId where
@@ -192,7 +202,7 @@ data WidgetRequest s e
   | RenderOnce
   -- | Useful if a widget requires periodic rendering. An optional maximum
   --   number of frames can be provided.
-  | RenderEvery WidgetId Int (Maybe Int)
+  | RenderEvery WidgetId Timestamp (Maybe Int)
   -- | Stops a previous periodic rendering request.
   | RenderStop WidgetId
   {-|
@@ -293,6 +303,8 @@ data WidgetEnv s e = WidgetEnv {
   _weOs :: Text,
   -- | Device pixel rate.
   _weDpr :: Double,
+  -- | The timestamp in milliseconds when the application started.
+  _weAppStartTs :: Timestamp,
   -- | Provides helper funtions for calculating text size.
   _weFontManager :: FontManager,
   -- | Returns the node info, and its parents', given a path from root.
@@ -325,7 +337,10 @@ data WidgetEnv s e = WidgetEnv {
   _weModel :: s,
   -- | The input status, mainly mouse and keyboard.
   _weInputStatus :: InputStatus,
-  -- | The timestamp when this cycle started.
+  {-|
+  The timestamp in milliseconds when this event/message cycle started. This
+  value starts from zero each time the application is run.
+  -}
   _weTimestamp :: Timestamp,
   {-|
   Whether the theme changed in this cycle. Should be considered when a widget

src/Monomer/Main/Core.hs

@@ -32,6 +32,8 @@ import Data.Maybe
 import Data.Map (Map)
 import Data.List (foldl')
 import Data.Text (Text)
+import Data.Time
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Graphics.GL
 
 import qualified Data.Map as Map
@@ -73,11 +75,11 @@ data MainLoopArgs sp e ep = MainLoopArgs {
   _mlOS :: Text,
   _mlRenderer :: Maybe Renderer,
   _mlTheme :: Theme,
-  _mlAppStartTs :: Int,
+  _mlAppStartTs :: Timestamp,
   _mlMaxFps :: Int,
-  _mlLatestRenderTs :: Int,
-  _mlFrameStartTs :: Int,
-  _mlFrameAccumTs :: Int,
+  _mlLatestRenderTs :: Timestamp,
+  _mlFrameStartTs :: Timestamp,
+  _mlFrameAccumTs :: Timestamp,
   _mlFrameCount :: Int,
   _mlExitEvents :: [e],
   _mlWidgetRoot :: WidgetNode sp ep,
@@ -142,7 +144,7 @@ runAppLoop window glCtx channel widgetRoot config = do
   let mainBtn = fromMaybe BtnLeft (_apcMainButton config)
   let contextBtn = fromMaybe BtnRight (_apcContextButton config)
 
-  startTs <- fmap fromIntegral SDL.ticks
+  appStartTs <- getCurrentTimestamp
   model <- use L.mainModel
   os <- liftIO getPlatform
   widgetSharedMVar <- liftIO $ newMVar Map.empty
@@ -154,6 +156,7 @@ runAppLoop window glCtx channel widgetRoot config = do
   let wenv = WidgetEnv {
     _weOs = os,
     _weDpr = dpr,
+    _weAppStartTs = appStartTs,
     _weFontManager = fontManager,
     _weFindBranchByPath = const Seq.empty,
     _weMainButton = mainBtn,
@@ -170,7 +173,7 @@ runAppLoop window glCtx channel widgetRoot config = do
     _weMainBtnPress = Nothing,
     _weModel = model,
     _weInputStatus = def,
-    _weTimestamp = startTs,
+    _weTimestamp = 0,
     _weThemeChanged = False,
     _weInTopLayer = const True,
     _weLayoutDirection = LayoutNone,
@@ -189,9 +192,9 @@ runAppLoop window glCtx channel widgetRoot config = do
     _mlRenderer = renderer,
     _mlTheme = theme,
     _mlMaxFps = maxFps,
-    _mlAppStartTs = 0,
+    _mlAppStartTs = appStartTs,
     _mlLatestRenderTs = 0,
-    _mlFrameStartTs = startTs,
+    _mlFrameStartTs = 0,
     _mlFrameAccumTs = 0,
     _mlFrameCount = 0,
     _mlExitEvents = exitEvents,
@@ -219,7 +222,7 @@ mainLoop
 mainLoop window fontManager config loopArgs = do
   let MainLoopArgs{..} = loopArgs
 
-  startTicks <- fmap fromIntegral SDL.ticks
+  startTs <- getEllapsedTimestamp _mlAppStartTs
   events <- SDL.pumpEvents >> SDL.pollEvents
 
   windowSize <- use L.windowSize
@@ -237,7 +240,7 @@ mainLoop window fontManager config loopArgs = do
   currWinSize <- liftIO $ getViewportSize window dpr
 
   let Size rw rh = windowSize
-  let ts = startTicks - _mlFrameStartTs
+  let ts = startTs - _mlFrameStartTs
   let eventsPayload = fmap SDL.eventPayload events
   let quit = SDL.QuitEvent `elem` eventsPayload
 
@@ -264,6 +267,7 @@ mainLoop window fontManager config loopArgs = do
   let wenv = WidgetEnv {
     _weOs = _mlOS,
     _weDpr = dpr,
+    _weAppStartTs = _mlAppStartTs,
     _weFontManager = fontManager,
     _weFindBranchByPath = findChildBranchByPath wenv _mlWidgetRoot,
     _weMainButton = mainBtn,
@@ -280,7 +284,7 @@ mainLoop window fontManager config loopArgs = do
     _weMainBtnPress = mainPress,
     _weModel = currentModel,
     _weInputStatus = inputStatus,
-    _weTimestamp = startTicks,
+    _weTimestamp = startTs,
     _weThemeChanged = False,
     _weInTopLayer = const True,
     _weLayoutDirection = LayoutNone,
@@ -305,10 +309,10 @@ mainLoop window fontManager config loopArgs = do
       handleResizeWidgets (seWenv, seRoot, Seq.empty)
     else return (seWenv, seRoot, Seq.empty)
 
-  endTicks <- fmap fromIntegral SDL.ticks
+  endTs <- getEllapsedTimestamp _mlAppStartTs
 
   -- Rendering
-  renderCurrentReq <- checkRenderCurrent startTicks _mlLatestRenderTs
+  renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs
 
   let useRenderThread = fromMaybe True (_apcUseRenderThread config)
   let renderEvent = any isActionEvent eventsPayload
@@ -328,14 +332,13 @@ mainLoop window fontManager config loopArgs = do
 
   let fps = realToFrac _mlMaxFps
   let frameLength = round (1000000 / fps)
-  let remainingMs = endTicks - startTicks
-  let tempDelay = abs (frameLength - remainingMs * 1000)
+  let remainingMs = endTs - startTs
+  let tempDelay = abs (frameLength - fromIntegral remainingMs * 1000)
   let nextFrameDelay = min frameLength tempDelay
-  let latestRenderTs = if renderNeeded then startTicks else _mlLatestRenderTs
+  let latestRenderTs = if renderNeeded then startTs else _mlLatestRenderTs
   let newLoopArgs = loopArgs {
-    _mlAppStartTs = _mlAppStartTs + ts,
     _mlLatestRenderTs = latestRenderTs,
-    _mlFrameStartTs = startTicks,
+    _mlFrameStartTs = startTs,
     _mlFrameAccumTs = if newSecond then 0 else _mlFrameAccumTs + ts,
     _mlFrameCount = if newSecond then 0 else _mlFrameCount + 1,
     _mlWidgetRoot = newRoot
@@ -469,7 +472,7 @@ watchWindowResize channel = do
         atomically $ writeTChan channel (MsgResize newSize)
       _ -> return ()
 
-checkRenderCurrent :: (MonomerM s e m) => Int -> Int -> m Bool
+checkRenderCurrent :: (MonomerM s e m) => Timestamp -> Timestamp -> m Bool
 checkRenderCurrent currTs renderTs = do
   renderCurrent <- use L.renderRequested
   schedule <- use L.renderSchedule
@@ -479,14 +482,14 @@ checkRenderCurrent currTs renderTs = do
     requiresRender = renderScheduleReq currTs renderTs
     renderNext schedule = any requiresRender schedule
 
-renderScheduleReq :: Int -> Int -> RenderSchedule -> Bool
+renderScheduleReq :: Timestamp -> Timestamp -> RenderSchedule -> Bool
 renderScheduleReq currTs renderTs schedule = required where
   RenderSchedule _ start ms _ = schedule
   stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms)
   stepTs = start + ms * stepCount
   required = renderTs < stepTs
 
-renderScheduleActive :: Int -> RenderSchedule -> Bool
+renderScheduleActive :: Timestamp -> RenderSchedule -> Bool
 renderScheduleActive currTs schedule = scheduleActive where
   RenderSchedule _ start ms count = schedule
   stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms)
@@ -503,3 +506,13 @@ isWindowExposed eventsPayload = not status where
 isMouseEntered :: [SDL.EventPayload] -> Bool
 isMouseEntered eventsPayload = not status where
   status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ]
+
+getCurrentTimestamp :: MonadIO m => m Timestamp
+getCurrentTimestamp = toMs <$> liftIO getCurrentTime
+  where
+    toMs = floor . (1e3 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
+
+getEllapsedTimestamp :: MonadIO m => Timestamp -> m Timestamp
+getEllapsedTimestamp start = do
+  ts <- getCurrentTimestamp
+  return (ts - start)

src/Monomer/Main/Handlers.hs

@@ -517,7 +517,7 @@ handleRenderOnce previousStep = do
 handleRenderEvery
   :: MonomerM s e m
   => WidgetId
-  -> Int
+  -> Timestamp
   -> Maybe Int
   -> HandlerStep s e
   -> m (HandlerStep s e)

src/Monomer/Main/Types.hs

@@ -59,8 +59,8 @@ be provided.
 -}
 data RenderSchedule = RenderSchedule {
   _rsWidgetId :: WidgetId,
-  _rsStart :: Int,
-  _rsMs :: Int,
+  _rsStart :: Timestamp,
+  _rsMs :: Timestamp,
   _rsRepeat :: Maybe Int
 } deriving (Eq, Show, Generic)
 

src/Monomer/Widgets/Animation/Fade.hs

@@ -54,7 +54,7 @@ Configuration options for fade:
 -}
 data FadeCfg e = FadeCfg {
   _fdcAutoStart :: Maybe Bool,
-  _fdcDuration :: Maybe Int,
+  _fdcDuration :: Maybe Timestamp,
   _fdcOnFinished :: [e]
 } deriving (Eq, Show)
 
@@ -80,7 +80,7 @@ instance CmbAutoStart (FadeCfg e) where
     _fdcAutoStart = Just start
   }
 
-instance CmbDuration (FadeCfg e) Int where
+instance CmbDuration (FadeCfg e) Timestamp where
   duration dur = def {
     _fdcDuration = Just dur
   }
@@ -92,7 +92,7 @@ instance CmbOnFinished (FadeCfg e) e where
 
 data FadeState = FadeState {
   _fdsRunning :: Bool,
-  _fdsStartTs :: Int
+  _fdsStartTs :: Timestamp
 } deriving (Eq, Show, Generic)
 
 instance Default FadeState where
@@ -141,7 +141,7 @@ makeFade isFadeIn config state = widget where
   autoStart = fromMaybe False (_fdcAutoStart config)
   duration = fromMaybe 500 (_fdcDuration config)
   period = 20
-  steps = duration `div` period
+  steps = fromIntegral $ duration `div` period
 
   finishedReq node = delayedMessage node AnimationFinished duration
   renderReq wenv node = req where