Changing -> Data.LVar

README.md

@@ -30,7 +30,8 @@ Run `bin/run` (or <kbd>Ctrl+Shift+B</kbd> in VSCode). This runs the clock exampl
   - [x] client to server reconnect (on ghcid reload, or accidental client disconnect)
     - [x] or, investigate https://hackage.haskell.org/package/ghci-websockets
 - [x] Multi-websocket-client support
-- [ ] Refactor Server.hs & Changing.hs
+- [ ] Refactor Server.hs
+- [ ] Publish Data.LVar to Hackage
 
 pre-announce,
 - [ ] plan features / messaging, re: hakyll

ema.cabal

@@ -9,7 +9,7 @@ category:           Web
 
 flag with-examples
   description: Include examples and their dependencies
-  default: True
+  default:     True
 
 -- A short (one-line) description of the package.
 -- synopsis:
@@ -26,8 +26,9 @@ extra-source-files:
   README.md
 
 data-files:
-  if flag(with-examples)
-    src/Ema/Example/Diary/*.org
+  flag(with-examples)
+  if
+  src/Ema/Example/Diary/*.org
 
 library
   -- Modules included in this executable, other than Main.
@@ -55,14 +56,15 @@ library
     , wai-websockets
     , warp
     , websockets
+
   if flag(with-examples)
     build-depends:
-      , fsnotify
-      , filepattern
       , directory
-      , time
+      , filepattern
+      , fsnotify
       , org-mode
       , shower
+      , time
 
   mixins:
     base hiding (Prelude),
@@ -85,13 +87,14 @@ library
     ViewPatterns
 
   other-modules:
+    Data.LVar
     Ema.App
-    Ema.Changing
     Ema.Layout
     Ema.Route
     Ema.Route.Slug
     Ema.Route.UrlStrategy
     Ema.Server
+
   if flag(with-examples)
     other-modules:
       Ema.Example.Ex01_HelloWorld

src/Data/LVar.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Data.LVar
+  ( -- * Types
+    LVar,
+    ListenerId,
+
+    -- * Creating a LVar
+    new,
+    empty,
+
+    -- * Modifying a LVar
+    get,
+    set,
+    modify,
+
+    -- * Listening to a LVar
+    listen,
+    ignore,
+  )
+where
+
+import qualified Data.Map.Strict as Map
+import Prelude hiding (empty, get, modify)
+
+-- A mutable variable with change notification
+-- TODO: Rename to something more accurate?
+data LVar a = LVar
+  { -- | A value that changes over time
+    lvarCurrent :: TMVar a,
+    -- | Subscribers listening on changes to the value
+    lvarListeners :: TMVar (Map ListenerId (TMVar ()))
+  }
+
+type ListenerId = Int
+
+new :: forall a m. MonadIO m => a -> m (LVar a)
+new val = do
+  LVar <$> newTMVarIO val <*> newTMVarIO mempty
+
+empty :: MonadIO m => m (LVar a)
+empty =
+  LVar <$> newEmptyTMVarIO <*> newTMVarIO mempty
+
+-- | Get the value of the @LVar@
+get :: MonadIO m => LVar a -> m a
+get v =
+  atomically $ readTMVar $ lvarCurrent v
+
+-- | Set the @LVar@ value; listeners from @listen@ are automatically notifed.
+set :: MonadIO m => LVar a -> a -> m ()
+set v = modify v . const
+
+-- | Modify the @LVar@ value
+modify :: MonadIO m => LVar a -> (a -> a) -> m ()
+modify v f = do
+  n <- atomically $ do
+    curr <- readTMVar (lvarCurrent v)
+    void $ swapTMVar (lvarCurrent v) (f curr)
+    notifyListeners v
+  when (n > 0) $
+    putStrLn $ "pub: published; " <> show n <> " subscribers listening"
+  where
+    notifyListeners :: LVar a -> STM Int
+    notifyListeners v' = do
+      subs <- readTMVar $ lvarListeners v'
+      forM_ (Map.elems subs) $ \subVar -> do
+        tryPutTMVar subVar ()
+      pure $ Map.size subs
+
+-- | Listen to changes to the @LVar@, as they are set by @set@ or @modify@
+--
+-- Returns a @ListenerId@ that can be used to stop listening later (via
+-- @ignore@), as well as an IO action that starts the listener.
+listen ::
+  MonadIO m =>
+  LVar a ->
+  (ListenerId -> a -> IO b) ->
+  m (ListenerId, IO ())
+listen v f = do
+  (idx, notify) <- atomically $ do
+    subs <- readTMVar $ lvarListeners v
+    let nextIdx = maybe 1 (succ . fst) $ Map.lookupMax subs
+    notify <- newEmptyTMVar
+    void $ swapTMVar (lvarListeners v) $ Map.insert nextIdx notify subs
+    pure (nextIdx, notify)
+  let runSubscription =
+        forever $ do
+          val :: a <- atomically $ do
+            takeTMVar notify
+            readTMVar (lvarCurrent v)
+          putStrLn $ "sub[" <> show idx <> "]: sending"
+          liftIO $ void $ f idx val
+  pure (idx, runSubscription)
+
+-- | Stop listening to the @LVar@
+ignore :: MonadIO m => LVar a -> ListenerId -> m ()
+ignore v subId = do
+  putStrLn $ "unsub - " <> show subId
+  atomically $ do
+    subs <- readTMVar $ lvarListeners v
+    whenJust (Map.lookup subId subs) $ \_sub -> do
+      void $ swapTMVar (lvarListeners v) $ Map.delete subId subs

src/Ema/App.hs

@@ -3,17 +3,17 @@
 
 module Ema.App where
 
-import Ema.Changing
-  ( Changing,
+import Data.LVar
+  ( LVar,
   )
-import qualified Ema.Changing as Changing
+import qualified Data.LVar as LVar
 import Ema.Route (IsRoute (..))
 import qualified Ema.Server as Server
 import GHC.IO.Handle (BufferMode (LineBuffering), hSetBuffering)
 
 data Ema s r = Ema
   { -- | The (ever-changing) state of the app
-    emaModel :: Changing s,
+    emaModel :: LVar s,
     -- | HTML view function over app state and app route
     emaRender :: s -> r -> LByteString
   }
@@ -29,7 +29,7 @@ runEmaPure ::
   (r -> LByteString) ->
   IO ()
 runEmaPure render = do
-  emptyModel <- Changing.empty
+  emptyModel <- LVar.empty
   runEma $ Ema emptyModel (const render)
 
 -- | Run Ema live server

src/Ema/Changing.hs

@@ -1,74 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Ema.Changing where
-
-import qualified Data.Map.Strict as Map
-import Prelude hiding (modify)
-
--- A mutable variable with change notification
--- TODO: Rename to something more accurate?
-data Changing a = Changing
-  { -- | A value that changes over time
-    changingCurrent :: TMVar a,
-    -- | Subscribers listening on changes to the value
-    changingSubscribers :: TMVar (Map Int (TMVar ()))
-  }
-
-new :: forall a m. MonadIO m => a -> m (Changing a)
-new val = do
-  Changing <$> newTMVarIO val <*> newTMVarIO mempty
-
-empty :: MonadIO m => m (Changing a)
-empty =
-  Changing <$> newEmptyTMVarIO <*> newTMVarIO mempty
-
-get :: MonadIO m => Changing a -> m a
-get v =
-  atomically $ readTMVar $ changingCurrent v
-
--- | Sets a new value; listeners from @subscribe@ are automatically notifed.
-set :: MonadIO m => Changing a -> a -> m ()
-set v = modify v . const
-
-modify :: MonadIO m => Changing a -> (a -> a) -> m ()
-modify v f = do
-  n <- atomically $ do
-    curr <- readTMVar (changingCurrent v)
-    void $ swapTMVar (changingCurrent v) (f curr)
-    publish v
-  when (n > 0) $
-    putStrLn $ "pub: published; " <> show n <> " subscribers listening"
-  where
-    publish :: Changing a -> STM Int
-    publish v' = do
-      subs <- readTMVar $ changingSubscribers v'
-      forM_ (Map.elems subs) $ \subVar -> do
-        tryPutTMVar subVar ()
-      pure $ Map.size subs
-
--- | Subscribes to new values as they are set by @set@.
-subscribe :: MonadIO m => Changing a -> (Int -> a -> IO b) -> m (Int, IO ())
-subscribe v f = do
-  (idx, notify) <- atomically $ do
-    subs <- readTMVar $ changingSubscribers v
-    let nextIdx = maybe 1 (succ . fst) $ Map.lookupMax subs
-    notify <- newEmptyTMVar
-    void $ swapTMVar (changingSubscribers v) $ Map.insert nextIdx notify subs
-    pure (nextIdx, notify)
-  let runSubscription =
-        forever $ do
-          val :: a <- atomically $ do
-            takeTMVar notify
-            readTMVar (changingCurrent v)
-          putStrLn $ "sub[" <> show idx <> "]: sending"
-          liftIO $ void $ f idx val
-  pure (idx, runSubscription)
-
-unsubscribe :: MonadIO m => Changing a -> Int -> m ()
-unsubscribe v subId = do
-  putStrLn $ "unsub - " <> show subId
-  atomically $ do
-    subs <- readTMVar $ changingSubscribers v
-    whenJust (Map.lookup subId subs) $ \_sub -> do
-      void $ swapTMVar (changingSubscribers v) $ Map.delete subId subs

src/Ema/Example/Ex02_Clock.hs

@@ -10,6 +10,7 @@ module Ema.Example.Ex02_Clock where
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
+import qualified Data.LVar as LVar
 import Data.List ((!!))
 import Data.Time
   ( UTCTime,
@@ -18,7 +19,6 @@ import Data.Time
     getCurrentTime,
   )
 import Ema.App (Ema (Ema), runEma)
-import qualified Ema.Changing as Changing
 import qualified Ema.Layout as Layout
 import Ema.Route (IsRoute (..))
 import Text.Blaze.Html5 ((!))
@@ -39,15 +39,15 @@ instance IsRoute Route where
     ["time"] -> Just OnlyTime
     _ -> Nothing
 
-changeTime :: Changing.Changing UTCTime -> IO ()
+changeTime :: LVar.LVar UTCTime -> IO ()
 changeTime model = do
   forever $ do
     threadDelay $ 1 * 1000000
-    Changing.set model =<< getCurrentTime
+    LVar.set model =<< getCurrentTime
 
 main :: IO ()
 main = do
-  model <- Changing.new =<< getCurrentTime
+  model <- LVar.new =<< getCurrentTime
   race_
     (changeTime model)
     (runEma $ Ema model render)

src/Ema/Example/Ex03_Diary.hs

@@ -9,6 +9,7 @@ module Ema.Example.Ex03_Diary where
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (race_)
 import Control.Exception (finally)
+import qualified Data.LVar as LVar
 import qualified Data.Map.Strict as Map
 import Data.Org (OrgFile)
 import qualified Data.Org as Org
@@ -16,7 +17,6 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import Data.Time (Day, defaultTimeLocale, parseTimeM)
 import Ema.App (Ema (..), runEma)
-import qualified Ema.Changing as Changing
 import qualified Ema.Layout as Layout
 import Ema.Route
 import qualified Shower
@@ -71,7 +71,7 @@ diaryFrom folder = do
   fs <- getDirectoryFiles folder (one "*.org")
   Map.fromList . catMaybes <$> forM fs (parseDailyNote . (folder </>))
 
-watchAndUpdateDiary :: FilePath -> Changing.Changing Diary -> IO ()
+watchAndUpdateDiary :: FilePath -> LVar.LVar Diary -> IO ()
 watchAndUpdateDiary folder model = do
   putStrLn $ "Watching .org files in " <> folder
   withManager $ \mgr -> do
@@ -82,11 +82,11 @@ watchAndUpdateDiary folder model = do
               Nothing -> pure ()
               Just (day, org) -> do
                 putStrLn $ "Update: " <> show day
-                Changing.modify model $ Map.insert day org
+                LVar.modify model $ Map.insert day org
           deleteFile fp = do
             whenJust (parseDailyNoteFilepath fp) $ \day -> do
               putStrLn $ "Delete: " <> show day
-              Changing.modify model $ Map.delete day
+              LVar.modify model $ Map.delete day
       case event of
         Added fp _ isDir -> unless isDir $ updateFile fp
         Modified fp _ isDir -> unless isDir $ updateFile fp
@@ -103,7 +103,7 @@ mainWith args = do
   folder <- case args of
     [path] -> canonicalizePath path
     _ -> canonicalizePath "src/Ema/Example/Diary"
-  model <- Changing.new =<< diaryFrom folder
+  model <- LVar.new =<< diaryFrom folder
   race_
     (runEma $ Ema model render)
     (watchAndUpdateDiary folder model)

src/Ema/Server.hs

@@ -6,9 +6,9 @@ module Ema.Server where
 
 import Control.Concurrent.Async (race_)
 import Control.Exception (try)
+import Data.LVar (LVar)
+import qualified Data.LVar as LVar
 import qualified Data.Text as T
-import Ema.Changing (Changing)
-import qualified Ema.Changing as Changing
 import Ema.Route (IsRoute (..))
 import NeatInterpolation (text)
 import qualified Network.HTTP.Types as H
@@ -21,7 +21,7 @@ import qualified Network.WebSockets as WS
 runServerWithWebSocketHotReload ::
   forall model route.
   (Show route, IsRoute route) =>
-  Changing model ->
+  LVar model ->
   (model -> route -> LByteString) ->
   IO ()
 runServerWithWebSocketHotReload model render = do
@@ -36,25 +36,25 @@ runServerWithWebSocketHotReload model render = do
         pathInfo <- pathInfoFromWsMsg <$> WS.receiveData @Text conn
         let r :: route = fromMaybe (error "invalid route from ws") $ routeFromPathInfo pathInfo
         log $ "Browser at route: " <> show r
-        (subId, send) <- Changing.subscribe model $ \subId (val :: model) -> do
+        (subId, send) <- LVar.listen model $ \subId (val :: model) -> do
           try (WS.sendTextData conn $ routeHtml val r) >>= \case
             Right () -> pure ()
             Left (err :: ConnectionException) -> do
               log $ "ws:send:: " <> show err
-              Changing.unsubscribe model subId
+              LVar.ignore model subId
         let recv = do
               try (WS.receiveDataMessage conn) >>= \case
                 Right (_ :: WS.DataMessage) -> recv
                 Left (err :: ConnectionException) -> do
                   log $ "ws:recv:: " <> show err
-                  Changing.unsubscribe model subId
+                  LVar.ignore model subId
         race_ recv send
     httpApp req f = do
       (status, v) <- case routeFromPathInfo (Wai.pathInfo req) of
         Nothing ->
           pure (H.status404, "No route")
         Just r -> do
-          val <- Changing.get model
+          val <- LVar.get model
           pure (H.status200, routeHtml val r)
       f $ Wai.responseLBS status [(H.hContentType, "text/html")] v
     routeFromPathInfo =