Shpadoinkle-backend-snabbdom 0.2.0.0 → 0.3.0.0

raw patch · 3 files changed

+95/−23 lines, 3 filesdep +exceptionsdep +monad-controldep +transformers-basePVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, monad-control, transformers-base

API changes (from Hackage documentation)

Files

• Shpadoinkle-backend-snabbdom.cabal +6/−3
• Shpadoinkle/Backend/Snabbdom.hs +88/−19
• Shpadoinkle/Backend/Snabbdom/Setup.js +1/−1

@@ -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

@@ -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

@@ -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);