prototype PIso

src/Ema/App.hs

@@ -59,7 +59,7 @@ runSiteWithCli cli site = do
           race_
             ( flip runLoggerLoggingT logger $ do
                 cont model
-                logWarnNS logSrc "modelPatcher exited; no more model updates."
+                logWarnNS logSrc "modelPatcher exited; no more model updates!"
                 liftIO $ threadDelay maxBound
             )
             (flip runLoggerLoggingT logger $ Server.runServerWithWebSocketHotReload host port site model)

src/Ema/Example/Ex02_Basic.hs

@@ -1,6 +1,9 @@
 -- | A very simple site with two routes, and HTML rendered using Blaze DSL
 module Ema.Example.Ex02_Basic where
 
+import Control.Concurrent (threadDelay)
+import Control.Monad.Logger (logInfoNS)
+import Data.LVar qualified as LVar
 import Ema
 import Ema.Example.Common (tailwindLayout)
 import Ema.Route (unsafeMkRouteEncoder)
@@ -13,7 +16,7 @@ data Route
   | About
   deriving stock (Show, Eq, Enum, Bounded)
 
-newtype Model r = Model (RouteEncoder (Model r) r)
+newtype Model = Model {modelMsg :: Text}
 
 routeEncoder :: RouteEncoder a Route
 routeEncoder =
@@ -29,7 +32,7 @@ routeEncoder =
       _ -> Nothing
     all_ _ = defaultEnum @Route
 
-site :: Site (Model Route) Route
+site :: Site Model Route
 site =
   Site
     { siteName = "Ex02",
@@ -38,21 +41,27 @@ site =
         enc <- askRouteEncoder
         pure $ Ema.AssetGenerated Ema.Html $ render enc m r,
       siteModelManager = ModelManager $ do
-        enc <- Ema.askRouteEncoder
-        pure (Model enc, \_ -> pure ()),
+        pure
+          ( Model "Hello!",
+            \lvar -> do
+              logInfoNS "Ex02" "Setting 2nd time"
+              LVar.modify lvar $ \_ -> Model "Hello, again."
+              -- Normally you would update the model over time.
+              liftIO $ threadDelay maxBound
+          ),
       siteRouteEncoder = routeEncoder
     }
 
 main :: IO ()
 main = do
   void $ Ema.runSite site
 
-render :: RouteEncoder (Model Route) Route -> Model Route -> Route -> LByteString
-render _enc model@(Model enc) r =
+render :: RouteEncoder Model Route -> Model -> Route -> LByteString
+render enc model@(Model msg) r =
   tailwindLayout (H.title "Basic site" >> H.base ! A.href "/") $
     H.div ! A.class_ "container mx-auto" $ do
       H.div ! A.class_ "mt-8 p-2 text-center" $ do
-        H.p $ H.em "Hello"
+        H.p $ H.em $ H.toHtml msg
         case r of
           Index -> do
             "You are on the index page. "

src/Ema/Example/Ex04_Multi.hs

@@ -16,7 +16,7 @@ data R
   | RBasicSite Ex02.Route
   | RClockSite Ex03.Route
 
-rEncoder :: RouteEncoder (Ex02.Model Ex03.Route, Ex03.Model) R
+rEncoder :: RouteEncoder (Ex02.Model, Ex03.Model) R
 rEncoder =
   unsafeMkRouteEncoder enc dec all_
   where

src/Ema/Route.hs

@@ -20,9 +20,8 @@ module Ema.Route
     Mergeable (merge),
 
     -- * Internal
-    mergeRouteEncoder,
     checkRouteEncoderForSingleRoute,
-    PartialIsoFunctor (pimap),
+    -- PartialIsoFunctor (pimap),
   )
 where
 
@@ -44,6 +43,51 @@ import Network.URI.Slug qualified as Slug
 newtype PartialIsoEnumerableWithCtx ctx s a
   = PartialIsoEnumerableWithCtx (ctx -> a -> s, ctx -> s -> Maybe a, ctx -> [a])
 
+-- | A partial Iso between `s` and `a`, with finite `a` values - and with access
+-- to some context `x`.
+newtype PIso x s a
+  = PIso
+      ( -- Encoder
+        a -> Reader x s,
+        -- Decoder
+        s -> ReaderT x Maybe a,
+        -- Universe
+        Reader x [a]
+      )
+
+piencode :: PIso r s a -> r -> a -> s
+piencode (PIso (f, _, _)) x =
+  flip runReader x . f
+
+pidecode :: PIso r s a -> r -> s -> Maybe a
+pidecode (PIso (_, f, _)) x =
+  flip runReaderT x . f
+
+piuniverse :: PIso r s a -> r -> [a]
+piuniverse (PIso (_, _, f)) = runReader f
+
+pimap' ::
+  Iso s1 (Maybe s1) s2 s2 ->
+  Iso a1 a1 (Maybe a2) a2 ->
+  (r2 -> r1) ->
+  PIso r1 s1 a1 ->
+  PIso r2 s2 a2
+pimap' sIso aIso rf (PIso (enc, dec, univ)) =
+  PIso (enc', dec', univ')
+  where
+    enc' a = withReader rf $ do
+      let a' = isoLeft aIso a
+      s' <- enc a'
+      pure $ isoRight sIso s'
+    dec' s = withReaderT rf $ do
+      s' <- lift $ isoLeft sIso s
+      a <- dec s'
+      lift $ isoRight aIso a
+    univ' = withReader rf $ do
+      mapMaybe (isoRight aIso) <$> univ
+    isoRight iso x = Lens.withIso iso $ \f _ -> f x
+    isoLeft iso x = Lens.withIso iso $ \_ f -> f x
+
 {-
 type T ctx a s = CtxIso ctx a (Maybe a) s s
 

src/Ema/Site.hs

@@ -155,31 +155,35 @@ instance Mergeable ModelManager where
     enc <- askRouteEncoder
     (v1, k1) <- runModelManager r1 cliAct $ leftRouteEncoder enc
     (v2, k2) <- runModelManager r2 cliAct $ rightRouteEncoder enc
-    l1 <- LVar.empty
-    l2 <- LVar.empty
-    LVar.set l1 v1
-    LVar.set l2 v2
+    l1 <- LVar.new v1
+    l2 <- LVar.new v2
     let v = (v1, v2)
         k lvar = runSiteM cliAct enc $ do
           let keepAlive src = do
                 -- TODO: DRY with App.hs
                 logWarnNS src "modelPatcher exited; no more model updates."
+                -- TODO: No need to do this just keep top-level thread alive.
                 threadDelay maxBound
+          sub1 <- LVar.addListener l1
+          sub2 <- LVar.addListener l2
           race_
             ( race_
                 (k1 l1 >> keepAlive "siteLeftTODO")
                 (k2 l2 >> keepAlive "siteRightTODO")
             )
             ( do
-                sub1 <- LVar.addListener l1
-                sub2 <- LVar.addListener l2
                 forever $
                   race
                     (LVar.listenNext l1 sub1)
                     (LVar.listenNext l2 sub2)
                     >>= \case
-                      Left a -> LVar.modify lvar $ first (const a)
-                      Right b -> LVar.modify lvar $ second (const b)
+                      Left a -> do
+                        -- FIXME: something wrong with initial update propagating here
+                        logDebugNS "merge-model" "left update"
+                        LVar.modify lvar $ first (const a)
+                      Right b -> do
+                        logDebugNS "merge-model" "right update"
+                        LVar.modify lvar $ second (const b)
             )
     pure (v, k)