diff --git a/Shpadoinkle-backend-snabbdom.cabal b/Shpadoinkle-backend-snabbdom.cabal --- a/Shpadoinkle-backend-snabbdom.cabal +++ b/Shpadoinkle-backend-snabbdom.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 6ac6720a8444015edf2b03ef30437c3c9ec703c559e4c205e6e1145bca8bdf91 +-- hash: 9632527e5d742c734473889b8289030711690a4689627731bcd9a2f549837e4d name: Shpadoinkle-backend-snabbdom -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Use the high-performance Snabbdom virtual dom library written in JavaScript. description: Snabbdom is a battle-tested virtual DOM library for JavaScript. It's extremely fast, lean, and modular. Snabbdom's design makes Snabbdom a natural choice for a Shpadoinkle rendering backend, as it has a similar core philosophy of "just don't do much" and is friendly to purely functional binding. category: Web @@ -36,10 +36,13 @@ build-depends: Shpadoinkle , base >=4.12.0 && <4.16 + , exceptions , file-embed >=0.0.11 && <0.1 , ghcjs-dom >=0.9.4 && <0.20 , jsaddle >=0.9.7 && <0.20 + , monad-control , mtl >=2.2.2 && <2.3 , text >=1.2.3 && <1.3 + , transformers-base , unliftio >=0.2.12 && <0.3 default-language: Haskell2010 diff --git a/Shpadoinkle/Backend/Snabbdom.hs b/Shpadoinkle/Backend/Snabbdom.hs --- a/Shpadoinkle/Backend/Snabbdom.hs +++ b/Shpadoinkle/Backend/Snabbdom.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -29,14 +30,23 @@ import Control.Category +import Control.Monad.Base (MonadBase (..), liftBaseDefault) +import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Reader +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl, + defaultLiftBaseWith, + defaultRestoreM) import Data.FileEmbed import Data.Text import Data.Traversable -import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM) -import Language.Javascript.JSaddle hiding (( # ), JSM, MonadJSM, liftJSM) +import Language.Javascript.JSaddle hiding (JSM, MonadJSM, liftJSM, + (#)) import Prelude hiding (id, (.)) -import UnliftIO.STM (TVar) +import UnliftIO (MonadUnliftIO (..), TVar, + UnliftIO (UnliftIO, unliftIO), + withUnliftIO) +import UnliftIO.Concurrent (forkIO) import Shpadoinkle hiding (children, name, props) @@ -50,7 +60,17 @@ newtype SnabbdomT model m a = Snabbdom { unSnabbdom :: ReaderT (TVar model) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadReader (TVar model), MonadTrans) + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader (TVar model) + , MonadTrans + , MonadTransControl + , MonadThrow + , MonadCatch + ) #ifndef ghcjs_HOST_OS @@ -58,24 +78,68 @@ #endif +instance MonadBase n m => MonadBase n (SnabbdomT model m) where + liftBase = liftBaseDefault + + +instance MonadBaseControl n m => MonadBaseControl n (SnabbdomT model m) where + type StM (SnabbdomT model m) a = ComposeSt (SnabbdomT model) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + + +instance MonadUnliftIO m => MonadUnliftIO (SnabbdomT r m) where + {-# INLINE askUnliftIO #-} + askUnliftIO = Snabbdom . ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r . unSnabbdom)) + {-# INLINE withRunInIO #-} + withRunInIO inner = + Snabbdom . ReaderT $ \r -> + withRunInIO $ \run' -> + inner (run' . flip runReaderT r . unSnabbdom) + + -- | 'SnabbdomT' is a @newtype@ of 'ReaderT', this is the 'runReaderT' equivalent. -runSnabbdom :: TVar model -> SnabbdomT model m a -> m a +runSnabbdom :: TVar model -> SnabbdomT model m ~> m runSnabbdom t (Snabbdom r) = runReaderT r t props :: Monad m => (m ~> JSM) -> TVar a -> [(Text, Prop (SnabbdomT a m) a)] -> JSM Object props toJSM i xs = do o <- create - a <- create - e <- create - c <- create + propsObj <- create + listenersObj <- create + classesObj <- create + attrsObj <- create + hooksObj <- create void $ xs `for` \(k, p) -> case p of + PData d -> unsafeSetProp (toJSString k) d propsObj + PPotato pot -> do + f' <- toJSVal . fun $ \_ _ -> + let + g vnode = do + vnode' <- valToObject vnode + stm <- pot . RawNode =<< unsafeGetProp "elm" vnode' + let go = atomically stm >>= writeUpdate i . hoist (toJSM . runSnabbdom i) + void $ forkIO go + in \case + [vnode] -> g vnode + [_, vnode] -> g vnode + _ -> return () + unsafeSetProp "insert" f' hooksObj + unsafeSetProp "update" f' hooksObj + PText t -> do t' <- toJSVal t true <- toJSVal True case k of - "className" | t /= "" -> forM_ (split (== ' ') t) $ \u -> unsafeSetProp (toJSString u) true c - _ -> unsafeSetProp (toJSString k) t' a + "className" | t /= "" -> forM_ (split (== ' ') t) $ \u -> unsafeSetProp (toJSString u) true classesObj + "style" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj + "type" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj + "autofocus" | t /= "" -> unsafeSetProp (toJSString k) t' attrsObj + _ -> unsafeSetProp (toJSString k) t' propsObj + PListener f -> do f' <- toJSVal . fun $ \_ _ -> \case [] -> return () @@ -83,17 +147,22 @@ rn <- unsafeGetProp "target" =<< valToObject ev x <- f (RawNode rn) (RawEvent ev) writeUpdate i $ hoist (toJSM . runSnabbdom i) x - unsafeSetProp (toJSString k) f' e + unsafeSetProp (toJSString k) f' listenersObj + PFlag b -> do f <- toJSVal b - unsafeSetProp (toJSString k) f a + unsafeSetProp (toJSString k) f propsObj - p <- toJSVal a - l <- toJSVal e - k <- toJSVal c - unsafeSetProp "props" p o - unsafeSetProp "class" k o - unsafeSetProp "on" l o + p <- toJSVal propsObj + l <- toJSVal listenersObj + k <- toJSVal classesObj + a <- toJSVal attrsObj + h' <- toJSVal hooksObj + unsafeSetProp "props" p o + unsafeSetProp "class" k o + unsafeSetProp "on" l o + unsafeSetProp "attrs" a o + unsafeSetProp "hook" h' o return o @@ -122,7 +191,7 @@ rn <- mrn ins <- toJSVal =<< function (\_ _ -> \case [n] -> void $ jsg2 "potato" n rn - _ -> return ()) + _ -> return ()) unsafeSetProp "insert" ins hook hoo <- toJSVal hook unsafeSetProp "hook" hoo o diff --git a/Shpadoinkle/Backend/Snabbdom/Setup.js b/Shpadoinkle/Backend/Snabbdom/Setup.js --- a/Shpadoinkle/Backend/Snabbdom/Setup.js +++ b/Shpadoinkle/Backend/Snabbdom/Setup.js @@ -13,7 +13,6 @@ addScript(cdnjs("snabbdom.min.js")); addScript(cdnjs("snabbdom-class.min.js")); addScript(cdnjs("snabbdom-props.min.js")); -addScript(cdnjs("snabbdom-style.min.js")); addScript(cdnjs("snabbdom-attributes.min.js")); addScript(cdnjs("snabbdom-eventlisteners.min.js")); addScript(cdnjs("h.min.js")); @@ -29,6 +28,7 @@ window.vnode = h.default; window.potato = (n, e) => n.elm.appendChild(e) window.container = document.createElement('div'); + document.body.innerHTML = ""; document.body.appendChild(container); cb(); }, 1000);