TodoMVC

Author: lagunoff

.gitignore

@@ -4,4 +4,5 @@ bin/**
 shell.nix
 doc
 dist-newstyle
-node_modules
+node_modules
+build

9.6.5.nix

@@ -3,7 +3,7 @@ let
     nixpkgs = builtins.fetchTarball {
       url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/24.05.tar.gz";
     };
-    ghc-wasm-meta = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org&ref=108e4693cd147777e8d93683e58c8a5e1da74c96";
+    ghc-wasm-meta = "gitlab:ghc/ghc-wasm-meta?host=gitlab.haskell.org&ref=455a759195e71c572e73b56d868e544176d32897";
   };
 
   pkgs = import sources.nixpkgs {};

Clickable/DOM.hs

@@ -11,12 +11,12 @@
 {-# OPTIONS_GHC -Wall #-}
 module Clickable.DOM where
 
-import Data.Text (Text)
-import GHC.Generics (Generic)
+import Clickable.Internal
 import Clickable.Types
-import Data.Kind
 import Data.Int
-import Clickable.Internal
+import Data.Kind
+import Data.Text (Text)
+import GHC.Generics (Generic)
 import Unsafe.Coerce
 
 

Clickable/HTML.hs

@@ -95,15 +95,15 @@ toggleClass className dynEnable = HTML \s e -> do
   pure ((), s')
 {-# INLINE toggleClass #-}
 
-attachTo :: JSExp -> HTML a -> JSM a
-attachTo rootEl contents = JSM \e -> do
-  e.ien_command $ PushStack rootEl
-  (r, _) <- contents.unHTML Nothing e
+execHTML :: JSExp -> HTML a -> JSM a
+execHTML elm action = JSM \e -> do
+  e.ien_command $ PushStack elm
+  (r, _) <- action.unHTML Nothing e
   e.ien_command PopStack
   pure r
 
-attach :: HTML a -> JSM a
-attach = attachTo $ Id "document" `Dot` "body"
+execHTMLBody :: HTML a -> JSM a
+execHTMLBody = execHTML $ Id "document" `Dot` "body"
 
 saveStackHead :: HTML RefId
 saveStackHead = HTML \s e ->
@@ -181,8 +181,8 @@ simpleList listDyn h = do
         pure InternalElem {elem_scope = scope, elem_state, placeholder = place'}
     dropElem :: InternalElem a -> JSM ()
     dropElem ie = do
-      destroyScope ie.elem_scope
       detachPlaceholder ie.placeholder
+      destroyScope ie.elem_scope
     updateList :: IORef [InternalElem a] -> [a] -> JSM ()
     updateList ref new = do
       ies <- liftIO $ readIORef ref
@@ -200,10 +200,3 @@ clearPlaceholder rid = jsCmd $ ClearPlaceholder $ Ref rid
 
 detachPlaceholder :: RefId -> JSM ()
 detachPlaceholder rid = jsCmd $ DetachPlaceholder $ Ref rid
-
-execHTML :: JSExp -> HTML a -> JSM a
-execHTML elm action = JSM \e -> do
-  e.ien_command $ PushStack elm
-  (r, _) <- action.unHTML Nothing e
-  e.ien_command PopStack
-  pure r

Clickable/Internal.hs

@@ -13,18 +13,21 @@ import Control.Monad.State.Strict
 import Data.Binary qualified as Binary
 import Data.Binary.Put (execPut)
 import Data.ByteString.Builder.Extra (runBuilder, Next (..), BufferWriter)
+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
 import Data.Functor.Const
 import Data.IORef
 import Data.List qualified as List
 import Data.Map qualified as Map
+import Data.Maybe
 import Data.Text (Text)
 import Data.Tuple (swap)
 import Foreign.C.String (CStringLen)
+import Foreign.Marshal (copyBytes)
 import Foreign.Marshal.Alloc (mallocBytes)
 import Foreign.Ptr
 import GHC.Exts
+import GHC.Stack
 import Unsafe.Coerce
-import Data.Maybe
 
 newEvent :: JSM (Event a)
 newEvent = state \s ->
@@ -359,11 +362,30 @@ jsCmd cmd = JSM \e ->
 jsEval :: JSExp -> JSM JSVal
 jsEval cmd = JSM \e -> do
   e.ien_command cmd
-  e.ien_flush
+  eid <- atomicModifyIORef' e.ien_state nextId
+  control e.ien_prompt_tag \c -> do
+    let jsc :: IO JSVal -> JSM ()
+        jsc a = JSM \_ -> c a
+        sub = Subscription e.ien_scope (unsafeCoerce jsc)
+    modifyIORef' e.ien_state \s -> s {
+      ist_subscriptions = Map.insert eid [sub] s.ist_subscriptions
+    }
+    e.ien_command $ Resume eid Out
+    e.ien_flush
+  where
+    nextId s = (s {ist_id_supply = s.ist_id_supply + 1}, EventId s.ist_id_supply)
 {-# INLINE jsEval #-}
 
 jsFlush :: JSM ()
 jsFlush = JSM \e -> void $ e.ien_flush
+{-# INLINE jsFlush #-}
+
+jsUnsafe :: (HasCallStack, FromJSVal a) => UnsafeJavaScript -> JSM a
+jsUnsafe ujs = do
+  j <- jsEval (Eval ujs)
+  case fromJSVal j of
+    Just a -> pure a
+    Nothing -> error "jsUnsafe: fromJSVal failed"
 
 commandBuffer :: CStringLen -> (CStringLen -> IO ()) -> IO (JSExp -> IO (), IO ())
 commandBuffer (buf, bufSize) consume = do
@@ -380,31 +402,17 @@ commandBuffer (buf, bufSize) consume = do
     writeCommand :: BufferWriter -> Int -> IO Int
     writeCommand bufWrite off = do
       (written, next) <- bufWrite (buf `plusPtr` off) (bufSize - off)
-      let off' = off + written
-      case next of
-        Done -> pure off'
-        More minSize _moreWrite
-          | off == 0 ->
-            error $ "Buffer too small, encountered command that requires at \
-                    \least " <> show minSize <> " bytes"
-          | otherwise -> do
-            consume (castPtr buf, off)
-            writeRemains bufWrite 0
-        Chunk chunk moreWrite -> do
-          off1 <- writeRemains (runBuilder $ execPut $ Binary.put chunk) off
-          writeRemains moreWrite off1
-
-    writeRemains :: BufferWriter -> Int -> IO Int
-    writeRemains bufWrite off = do
-      (written, next) <- bufWrite (buf `plusPtr` off) (bufSize - off)
-      let off' = off + written
-      case next of
-        Done -> pure off'
-        More _minSize _moreWrite ->
-          error $ "Buffer too small, inscrease the buffer size"
-        Chunk chunk moreWrite -> do
-          off1 <- writeRemains (runBuilder $ execPut $ Binary.put chunk) off
-          writeRemains moreWrite off1
+      writeNext next $ off + written
+
+    writeNext :: Next -> Int -> IO Int
+    writeNext Done off = pure off
+    writeNext (More minSize _) _off =
+      error $ "Buffer too small, encountered command that requires at \
+              \least " <> show minSize <> " bytes"
+    writeNext (Chunk chunk more) off =
+      unsafeUseAsCStringLen chunk \(zs, len) -> do
+        copyBytes (buf `plusPtr` off) zs len
+        writeCommand more (off + len)
 
     flush :: IORef Int -> IO ()
     flush ref = do
@@ -414,24 +422,18 @@ commandBuffer (buf, bufSize) consume = do
 newInternalEnv :: Int -> (CStringLen -> IO ()) -> IO (InternalEnv, CStringLen)
 newInternalEnv bufSize consume = do
   buf <- mallocBytes bufSize
-  ien_state <- newIORef emptyState
-  (write, flush) <- commandBuffer (buf, bufSize) consume
-  ien_prompt_tag <- newPromptTag
-  ien_continuations <- newIORef Map.empty
-  let bufResult = (castPtr buf, bufSize)
-  pure (
-    InternalEnv {
-      ien_command = write,
-      ien_flush = do
-        tid <- atomicModifyIORef' ien_state \s ->
-          (s {ist_id_supply = s.ist_id_supply + 1}, ContId s.ist_id_supply)
-        write $ Resume tid
-        flush
-        control ien_prompt_tag \c ->
-          modifyIORef' ien_continuations $ Map.insert tid c,
-      ien_state,
-      ien_scope = ScopeId 0,
-      ien_prompt_tag,
-      ien_continuations
-    }, bufResult
-    )
+  let strLen = (castPtr buf, bufSize)
+  ienv <- mkEnv buf
+  pure (ienv, strLen)
+  where
+    mkEnv buf = do
+      ien_prompt_tag <- newPromptTag
+      ien_state <- newIORef emptyState
+      (write, flush) <- commandBuffer (buf, bufSize) consume
+      pure InternalEnv {
+          ien_command = write,
+          ien_flush = flush,
+          ien_state,
+          ien_scope = ScopeId 0,
+          ien_prompt_tag
+        }

Clickable/Types.hs

@@ -32,14 +32,16 @@ import GHC.Generics qualified as G
 import GHC.List qualified as List
 import GHC.Types
 import GHC.Generics
+import Control.Monad.Fix
 
 newtype JSM a = JSM {unJSM :: InternalEnv -> IO a}
   deriving (
     Functor,
     Applicative,
     Monad,
     MonadIO,
-    MonadReader InternalEnv
+    MonadReader InternalEnv,
+    MonadFix
   ) via ReaderT InternalEnv IO
 
 instance MonadState InternalState JSM where
@@ -55,11 +57,10 @@ class MonadJSM m where
 
 data InternalEnv = InternalEnv {
   ien_command :: JSExp -> IO (),
-  ien_flush :: IO JSVal,
+  ien_flush :: IO (),
   ien_state :: IORef InternalState,
   ien_scope :: ScopeId,
-  ien_prompt_tag :: PromptTag (),
-  ien_continuations :: IORef (Map ContId (IO JSVal -> IO ()))
+  ien_prompt_tag :: PromptTag ()
 }
 
 data InternalState = InternalState {
@@ -85,7 +86,8 @@ newtype HTML a = HTML {unHTML :: Maybe RefId -> InternalEnv -> IO (a, Maybe RefI
     Functor,
     Applicative,
     Monad,
-    MonadIO
+    MonadIO,
+    MonadFix
   ) via StateT (Maybe RefId) JSM
 
 instance MonadJSM HTML where
@@ -152,16 +154,17 @@ data JSExp where
 
   Eval :: UnsafeJavaScript -> JSExp
   TriggerEvent :: EventId -> JSExp -> JSExp
-  Resume :: ContId -> JSExp
+  Resume :: EventId -> JSExp -> JSExp
+  Out :: JSExp
 
   deriving stock (Generic, Show)
   deriving anyclass Binary
 
 data ClientMsg where
   StartMsg :: StartFlags -> ClientMsg
   EventMsg :: EventId -> JSExp -> ClientMsg
-  ResumeMsg :: ContId -> JSExp -> ClientMsg
-  deriving stock Generic
+  ResumeMsg :: EventId -> JSExp -> ClientMsg
+  deriving stock (Generic, Show)
   deriving anyclass Binary
 
 -- | JavaScript value, result of evaluating an 'JSExp'. Should only
@@ -170,7 +173,7 @@ data ClientMsg where
 type JSVal = JSExp
 
 newtype StartFlags = StartFlags {unStartFlags :: JSVal}
-  deriving newtype Binary
+  deriving newtype (Binary, Show)
 
 newtype ScopeId = ScopeId {unScopeId :: Word32}
   deriving newtype (Binary, Eq, Ord, Show)
@@ -181,9 +184,6 @@ newtype RefId = RefId {unRefId :: Word32}
 newtype EventId = EventId {unEventId :: Word32}
   deriving newtype (Show, Ord, Eq, Binary)
 
-newtype ContId = ContId {unContId :: Word32}
-  deriving newtype (Show, Ord, Eq, Binary)
-
 newtype UnsafeJavaScript = UnsafeJavaScript {unUnsafeJavaScript :: Text}
   deriving newtype (IsString, Show, Semigroup, Monoid, Binary)
 

Clickable/Wasm.hs renamed to Clickable/WASM.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE GHC2024 #-}
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE LambdaCase #-}
@@ -9,59 +8,62 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# OPTIONS_GHC -Wno-unused-do-bind #-}
-module Clickable.Wasm where
+{-# OPTIONS_GHC -Wall #-}
+module Clickable.WASM where
 
 import Clickable.Internal
 import Clickable.Types
-import Control.Monad
 import Data.Binary (Binary)
+import Data.Binary qualified as Binary
 import Data.ByteString (ByteString)
-import Data.IORef
+import Data.ByteString.Lazy qualified as BSL
+import Data.ByteString.Unsafe qualified as BSU
 import Data.Word
+import Foreign.C.String (CStringLen)
 import Foreign.Ptr
 import System.IO.Unsafe (unsafePerformIO)
-import qualified Data.Binary as Binary
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.ByteString.Unsafe as BSU
-import qualified Data.Map as Map
-import Data.Tuple (swap)
-import Data.Map (Map)
-import Foreign.C.String (CStringLen)
+import GHC.Exts
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
+import Data.IORef
+import Control.Monad
+import Unsafe.Coerce
+import System.IO
 
 foreign import ccall safe
   "clickable_eval_buffer" clickable_eval_buffer :: Ptr Word8 -> Int -> IO ()
 
 env :: InternalEnv
 {-# NOINLINE env #-}
 
-continuations :: IORef (Map Word32 (IO JSVal -> IO ()))
-{-# NOINLINE continuations #-}
-
 buf :: CStringLen
 {-# NOINLINE buf #-}
 
-(env, continuations, buf) = unsafePerformIO $
+(env, buf) = unsafePerformIO $
   newInternalEnv (100 * 1024) \(ptr, len) ->
     clickable_eval_buffer (castPtr ptr) len
 
-mkWasmApp :: JSM () -> Ptr Word8 -> IO (Ptr Word8)
-mkWasmApp app p | p == nullPtr = do
-  runTransition env app
+mkWasmApp :: (StartFlags -> JSM ()) -> Ptr Word8 -> IO (Ptr Word8)
+mkWasmApp _app p | p == nullPtr = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stderr LineBuffering
   return $ castPtr $ fst buf
 mkWasmApp app inmsg = do
   msg <- loadMessage inmsg $ snd buf
   case msg of
-    Just (StartMsg _flags) ->
-      runTransition env app
+    Just (StartMsg flags) ->
+      runJSM env $ app flags
     Just (EventMsg eventId pload) ->
-      runTransition env $
-        triggerEvent (unsafeFromEventId eventId) pload
+      runJSM env $ triggerEvent (unsafeFromEventId eventId) pload
     Just (ResumeMsg contId pload) -> do
-      awatingThread <- atomicModifyIORef' continuations $
-        swap . Map.alterF (,Nothing) contId
-      forM_ awatingThread \cont -> cont $ pure pload
+      cont <- atomicModifyIORef' env.ien_state $ lookupCont $ coerce contId
+      forM_ cont \c -> runJSM env $ c.sub_callback $ unsafeCoerce $ ((pure pload) :: IO JSVal)
     _ -> error "mkWasmApp: Failed to parse incomming command"
-  return $ castPtr $ fst buf
+  pure $ castPtr $ fst buf
+  where
+    lookupCont :: EventId -> InternalState -> (InternalState, [Subscription Any])
+    lookupCont eventId s = (s {ist_subscriptions = subs}, fromMaybe [] cont) where
+      (cont, subs) = Map.alterF (,Nothing) eventId $ s.ist_subscriptions
 
 loadMessage :: Binary msg => Ptr a -> Int -> IO (Maybe msg)
 loadMessage p len