WIP

turion · Dec 2, 2024 · ba7fbdf · ba7fbdf
1 parent 9685223
commit ba7fbdf
Show file tree

Hide file tree

Showing 5 changed files with 88 additions and 12 deletions.
diff --git a/rhine-tree/app/Dommy.hs b/rhine-tree/app/Dommy.hs
@@ -7,6 +7,7 @@ import Control.Monad (forever)
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.Monoid ((<>))
 import Language.Javascript.JSaddle (
+  JSM,
   askJSM,
   fun,
   global,
@@ -22,20 +23,22 @@ import Language.Javascript.JSaddle (
   valToJSON
  )
 
-import FRP.Rhine
+import FRP.Rhine hiding (forever)
 import FRP.Rhine.Tree
 import FRP.Rhine.Tree.Types (DOM(..))
 import FRP.Rhine.Tree.Types (Node(..), Content (ContentText))
 
-import Language.Javascript.JSaddle
+import Data.Text (Text)
+default (Text)
 
 main :: JSM ()
 main = do
   clock <- createJSMClock
+  logJS "created"
   flowJSM mainClSF clock
 
 mainClSF :: JSMSF DOM () ()
 mainClSF = mconcat
-  [ appendS $ DOM [Node "p" [] [ContentText "Hi"]]
-  , permanent $ Node "p" [] [ContentText "Foo"]
+  [ appendS $ DOM [Node ("p" :: Text) [] [ContentText ("Hi" :: Text)]]
+  , permanent $ Node ("p" :: Text) [] [ContentText ("Foo" :: Text)]
   ]
diff --git a/rhine-tree/rhine-tree.cabal b/rhine-tree/rhine-tree.cabal
@@ -50,6 +50,7 @@ executable dommy
         rhine,
         rhine-tree,
         jsaddle,
+        text,
         lens
     ghc-options: -threaded
     hs-source-dirs: app

diff --git a/rhine-tree/src/FRP/Rhine/Tree.hs b/rhine-tree/src/FRP/Rhine/Tree.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Arrows #-}
 module FRP.Rhine.Tree where
 
 -- base
@@ -17,6 +18,7 @@ import Control.Applicative (Alternative)
 
 import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
 import Control.Lens (Index, IndexedTraversal', IxValue, Ixed (..), Lens', Prism', Traversal', itraversed, re, to, view, (%~), (<.), (^.), (^?), (^@..))
+import Control.Monad (void)
 import Control.Monad.Trans.Reader (ReaderT (..))
 import Control.Monad.Trans.State.Strict (StateT (..))
 import Control.Monad.Trans.State.Strict qualified as StateT
@@ -37,9 +39,10 @@ import Data.Text qualified as T hiding (length)
 import Data.These (these)
 import FRP.Rhine hiding (readerS, runReaderS, step)
 import FRP.Rhine.Tree.Types
-import Language.Javascript.JSaddle (MonadJSM (..), fun, js, jsg, jss, syncPoint, valToNumber)
+import Language.Javascript.JSaddle (MonadJSM (..), fun, js, js1, jsg, jss, syncPoint, valToNumber)
 import Language.Javascript.JSaddle.Types (JSM)
 import Prelude hiding (unzip)
+import Data.Automaton.Trans.State (runStateS)
 
 default (Text)
 
@@ -159,10 +162,11 @@ instance Render Node where
       ]
 
 instance Render DOM where
-  render DOM {_dom} =
-    T.unlines $
-      "<!doctype html>"
-        : (render <$> _dom)
+  render DOM {_dom} = T.unlines $ render <$> _dom
+
+-- T.unlines $
+--   "<!doctype html>"
+--     : (render <$> _dom)
 
 data Edit a = Add a | Delete | Put a
 
@@ -208,17 +212,26 @@ createJSMClock = do
 -- FIXME Next iteration: Cache DOM and only update diff
 runStateTDOM :: StateT DOM JSM a -> JSM a
 runStateTDOM action = do
+  logJS "starting runStateTDOM"
   (a, dom_) <- runStateT action mempty
+  logJS "Calculated:"
+  logJS $ render dom_
   doc <- jsg ("document" :: Text)
   doc ^. js ("body" :: Text) ^. jss ("innerHTML" :: Text) (render dom_)
+  logJS "done"
   syncPoint -- FIXME needed?
   return a
 
+runStateTDOMS :: JSMSF DOM a b -> ClSF JSM JSMClock a b
+runStateTDOMS sf = feedback mempty $ proc (a, dom_) -> do
+  ClSF.runStateS sf -< _
+  _ -< _
+
 -- FIXME generalise
 type JSMSF node a b = ClSF (StateT node JSM) JSMClock a b
 
 flowJSM :: JSMSF DOM () () -> JSMClock -> JSM ()
-flowJSM sf cl = runStateTDOM $ flow $ sf @@ cl
+flowJSM sf cl = flow $ runStateTDOMS sf @@ cl
 
 stateS :: (Monad m) => (a -> s -> (b, s)) -> ClSF (StateT s m) cl a b
 stateS f = arrMCl $ StateT.state . f
@@ -229,7 +242,7 @@ appendS s = constMCl $ StateT.modify (<> s)
 jsmSF ::
   forall a output input.
   ( Ixed a,
-  HasEvent a,
+    HasEvent a,
     Event a ~ JSMEvent -- FIXME get rid of that constraint
   ) =>
   JSMSF a input (Maybe output) ->
@@ -250,7 +263,7 @@ class (Ixed a) => AppendChild a where
 
 instance AppendChild DOM where
   -- FIXME This is super inefficient, should use a vector or a Seq
-  appendChild node dom_ = ( dom_ ^. dom . to length, dom_ & dom %~ (++ [node]))
+  appendChild node dom_ = (dom_ ^. dom . to length, dom_ & dom %~ (++ [node]))
 
 instance AppendChild Node where
   -- FIXME This is super inefficient, should use a vector or a Seq
@@ -262,3 +275,8 @@ class Register m a where
 permanent :: (AppendChild node) => IxValue node -> JSMSF node a ()
 -- permanent v = jsmSF (arr (const Nothing)) (constMCl (StateT.put v)) >>> arr (const ())
 permanent v = constMCl $ StateT.state (appendChild v) <&> const ()
+
+logJS :: Text -> JSM ()
+logJS msg = do
+  c <- jsg ("console" :: Text)
+  void $ c ^. js1 ("log" :: Text) msg
diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
@@ -101,6 +101,7 @@ library
     FRP.Rhine.ClSF.Except
     FRP.Rhine.ClSF.Random
     FRP.Rhine.ClSF.Reader
+    FRP.Rhine.ClSF.State
     FRP.Rhine.ClSF.Upsample
     FRP.Rhine.ClSF.Util
     FRP.Rhine.Clock

diff --git a/rhine/src/FRP/Rhine/ClSF/State.hs b/rhine/src/FRP/Rhine/ClSF/State.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{- |
+Create and remove 'StateT' layers in 'ClSF's.
+-}
+module FRP.Rhine.ClSF.State where
+
+-- base
+import Data.Tuple (swap)
+
+-- transformers
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State.Strict
+
+-- automaton
+import Data.Automaton.Trans.State qualified as Automaton
+
+-- rhine
+import FRP.Rhine.ClSF.Core
+
+commuteState :: ReaderT r (StateT s m) a -> StateT s (ReaderT r m) a
+commuteState a =
+  StateT $ \s -> ReaderT $ \r -> runStateT (runReaderT a r) s
+{-# INLINE commuteState #-}
+
+commuteStateBack :: StateT s (ReaderT r m) a -> ReaderT r (StateT s m) a
+commuteStateBack a =
+  ReaderT $ \r -> StateT $ \s -> runReaderT (runStateT a s) r
+{-# INLINE commuteStateBack #-}
+
+stateS ::
+  (Monad m) =>
+  ClSF m cl (s, a) (s, b) ->
+  ClSF (StateT s m) cl a b
+stateS behaviour = hoistS commuteStateBack $ Automaton.stateS behaviour
+{-# INLINE stateS #-}
+
+runStateS ::
+  (Monad m) =>
+  ClSF (StateT s m) cl a b ->
+  ClSF m cl (s, a) (s, b)
+runStateS behaviour = Automaton.runStateS (hoistS commuteState behaviour)
+{-# INLINE runStateS #-}
+
+runStateS_ ::
+  (Monad m) =>
+  ClSF (StateT s m) cl a b ->
+  s ->
+  ClSF m cl a (s, b)
+runStateS_ behaviour s = Automaton.runStateS_ (hoistS commuteState behaviour) s
+{-# INLINE runStateS_ #-}