diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Shpadoinkle Backend Snabbdom -[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle) +[![Goldwater](https://gitlab.com/platonic/shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/platonic/shpadoinkle) [![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/backend-snabbdom) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org) @@ -12,7 +12,23 @@ > Snabbdom consists of an extremely simple, performant, and extensible core that is only ≈ 200 SLOC. It offers a modular architecture with rich functionality for extensions through custom modules. To keep the core simple, all non-essential functionality is delegated to modules. -These design decisions made Snabbdom a good fit for Shpadoinkle's first high-performance pure JavaScript backend. Right now Snabbdom is being provided using [CloudFlare](https://cdnjs.com/) content delivery network (CDN) and is not included in this repo. This is great for getting started fast and having a transparent developer experience where you can simply switch to the backend of your choosing. However, this is not a stable long term approach as the CDN artifact could be removed at any time. If you wish to use Snabbdom in production, I recommend either: +These design decisions made Snabbdom a good fit for Shpadoinkle's first high-performance pure JavaScript backend. Right now Snabbdom is being provided statically, and a [slightly modified build](https://github.com/fresheyeball/snabbdom) is included in this repo. Although this increases the size of the resulting executable, it's necessary for reproducible and stable builds. -- Proactively monitoring the CDN endpoints -- Wrap `SnabbdomT` in your own `newtype` and overriding the `setup` method in the `Backend` instance with a mechanism where you provide Snabbdom's JavaScript artifacts yourself. +# Building + +In order to re-build `Shpadoinkle/Backend/Snabbdom/Setup.js`, it needs to be bundled with a tool like [parcel](https://parceljs.org/) - the following methodology is how it's currently done: + +```bash +# clone outside the source directory of Shpadoinkl +git clone git@github.com:snabbdom/snabbdom.git +# compile its typescript so we can bundle the javascript +cd snabbdom && npm install && npm run compile +# Setup_src.js imports the snabbdom sources locally, so we need to manually move it +cp path-to-shpadoinkle/backends/snabbdom/Shpadoinkle/Backend/Snabbdom/Setup_src.js build/package/ +# nix is most reliable for running parcel +nix-shell -p nodePackages.parcel-bundler --command "parcel build build/package/Setup_src.js" +# copy the bundled output as Setup.js +cp dist/Setup_src.js path-to-shpadoinkle/backends/snabbdom/Shpadoinkle/Backend/Snabbdom/Setup.js +``` + +Now when you build your shpadoinkle project, this new `Setup.js` will be statically allocated with your GHCJS output. diff --git a/Shpadoinkle-backend-snabbdom.cabal b/Shpadoinkle-backend-snabbdom.cabal --- a/Shpadoinkle-backend-snabbdom.cabal +++ b/Shpadoinkle-backend-snabbdom.cabal @@ -1,41 +1,48 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 69cf96a52080c262156727e824b26eaebddc6ac0713edcc0f367f821161c934b - -name: Shpadoinkle-backend-snabbdom -version: 0.3.0.1 -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 -author: Isaac Shapira -maintainer: fresheyeball@protonmail.com -license: BSD3 -license-file: LICENSE -build-type: Simple +cabal-version: 2.2 +name: Shpadoinkle-backend-snabbdom +version: 0.3.0.2 +category: Web +author: Isaac Shapira +maintainer: isaac.shapira@platonic.systems +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple extra-source-files: - README.md - CHANGELOG.md - Shpadoinkle/Backend/Snabbdom/Setup.js + README.md + Shpadoinkle/Backend/Snabbdom/Setup.js +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. + source-repository head type: git - location: https://gitlab.com/fresheyeball/Shpadoinkle.git + location: https://gitlab.com/platonic/shpadoinkle.git + library exposed-modules: - Shpadoinkle.Backend.Snabbdom - other-modules: - Paths_Shpadoinkle_backend_snabbdom - hs-source-dirs: - ./. - ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities + Shpadoinkle.Backend.Snabbdom + + hs-source-dirs: . + + ghc-options: + -Wall + -Wcompat + -fwarn-redundant-constraints + -fwarn-incomplete-uni-patterns + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-identities + build-depends: Shpadoinkle , base >=4.12.0 && <4.16 + , containers , exceptions , file-embed >=0.0.11 && <0.1 , ghcjs-dom >=0.9.4 && <0.20 @@ -45,4 +52,5 @@ , 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -30,31 +32,51 @@ import Control.Category ((.)) +#ifdef ghcjs_HOST_OS +import Control.Monad (join) +#endif import Control.Monad.Base (MonadBase (..), liftBaseDefault) -import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Cont (MonadCont) +import Control.Monad.Except (MonadError) import Control.Monad.Reader (MonadIO, MonadReader (..), MonadTrans, ReaderT (..), forM_, - void, (>=>)) + void) +import Control.Monad.State (MonadState) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl, defaultLiftBaseWith, defaultRestoreM) +import Control.Monad.Writer (MonadWriter) import Data.FileEmbed (embedStringFile) -import Data.Text (Text, split) -import Data.Traversable (for) +import Data.Map.Internal (Map (Bin, Tip)) +import Data.Text (Text, isPrefixOf, words) import GHCJS.DOM (currentDocumentUnchecked) import GHCJS.DOM.Document (createElement, getBodyUnsafe) -import GHCJS.DOM.Element (setAttribute) +import GHCJS.DOM.Element (setAttribute, setInnerHTML) import GHCJS.DOM.Node (appendChild) -import Language.Javascript.JSaddle hiding (JSM, MonadJSM, liftJSM, - (#)) -import Prelude hiding (id, (.)) +#ifndef ghcjs_HOST_OS +import Language.Javascript.JSaddle (FromJSVal (..), JSVal, Object, + ToJSVal (..), create, eval, fun, + function, jsTrue, jsg1, jsg2, + jsg3, toJSBool, toJSString, + unsafeGetProp, unsafeSetProp, + valMakeText, valToObject) +#else +import Language.Javascript.JSaddle (FromJSVal (..), JSVal, Object, + ToJSVal (..), create, eval, fun, + function, jsTrue, toJSBool, + toJSString, unsafeGetProp, + unsafeSetProp, valMakeText, + valToObject) +#endif +import Prelude hiding (id, words, (.)) import UnliftIO (MonadUnliftIO (..), TVar, UnliftIO (UnliftIO, unliftIO), withUnliftIO) import UnliftIO.Concurrent (forkIO) -import Shpadoinkle hiding (children, name, props) +import Shpadoinkle default (Text) @@ -71,14 +93,22 @@ , Applicative , Monad , MonadIO - , MonadReader (TVar model) , MonadTrans , MonadTransControl , MonadThrow , MonadCatch + , MonadMask + , MonadWriter w + , MonadState s + , MonadError e + , MonadCont ) +snabbAsk :: Monad m => SnabbdomT model m (TVar model) +snabbAsk = Snabbdom ask + + #ifndef ghcjs_HOST_OS deriving instance MonadJSM m => MonadJSM (SnabbdomT model m) #endif @@ -88,6 +118,11 @@ liftBase = liftBaseDefault +instance MonadReader r m => MonadReader r (SnabbdomT a m) where + ask = Snabbdom . ReaderT $ const ask + local f (Snabbdom rs) = Snabbdom $ ReaderT $ local f . runReaderT rs + + instance MonadBaseControl n m => MonadBaseControl n (SnabbdomT model m) where type StM (SnabbdomT model m) a = ComposeSt (SnabbdomT model) m a liftBaseWith = defaultLiftBaseWith @@ -111,54 +146,79 @@ 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 +traverseWithKey_ :: Applicative t => (k -> a -> t ()) -> Map k a -> t () +traverseWithKey_ f = go + where + go Tip = pure () + go (Bin 1 k v _ _) = f k v + go (Bin _ k v l r) = go l *> f k v *> go r +{-# INLINE traverseWithKey_ #-} +{-# SPECIALIZE traverseWithKey_ :: (k -> a -> JSM ()) -> Map k a -> JSM () #-} + + +insertHook :: Text -> JSVal -> Object -> JSM () +#ifndef ghcjs_HOST_OS +insertHook t f' hooksObj = void $ jsg3 "insertHook" t f' hooksObj +#else +insertHook t f' hooksObj = join $ insertHook' <$> toJSVal t <*> pure f' <*> toJSVal hooksObj +foreign import javascript unsafe "window['insertHook']($1,$2,$3)" insertHook' :: JSVal -> JSVal -> JSVal -> JSM () +#endif + + +{-# SPECIALIZE props :: NFData a => (JSM ~> JSM) -> TVar a -> Props (SnabbdomT a JSM) a -> JSM Object #-} +props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (SnabbdomT a m) a -> JSM Object +props toJSM i (Props xs) = do o <- 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 -> - if u == mempty then pure () else 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 + flip traverseWithKey_ xs $ \k p -> + let k' = toJSString k + in case p of + PData d -> unsafeSetProp 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 () + insertHook "insert" f' hooksObj + insertHook "update" f' hooksObj + PText t + | k == "className" -> forM_ (words t) $ \u -> + unsafeSetProp (toJSString u) jsTrue classesObj + | t /= "" -> do + t' <- valMakeText t + unsafeSetProp k' t' $ case k of + "style" -> attrsObj + "type" -> attrsObj + "autofocus" -> attrsObj + "checked" -> attrsObj + d | "data-" `isPrefixOf` d -> attrsObj + _ -> propsObj + | otherwise -> do + t' <- valMakeText t + unsafeSetProp k' t' propsObj - PListener f -> do - f' <- toJSVal . fun $ \_ _ -> \case - [] -> return () - ev:_ -> do - rn <- unsafeGetProp "target" =<< valToObject ev - x <- f (RawNode rn) (RawEvent ev) - writeUpdate i $ hoist (toJSM . runSnabbdom i) x - unsafeSetProp (toJSString k) f' listenersObj + PListener f -> do + f' <- toJSVal . fun $ \_ _ -> \case + [] -> return () + ev:_ -> do + rn <- unsafeGetProp "target" =<< valToObject ev + x <- f (RawNode rn) (RawEvent ev) + writeUpdate i $ hoist (toJSM . runSnabbdom i) x + unsafeSetProp k' f' listenersObj - PFlag b -> do - f <- toJSVal b - unsafeSetProp (toJSString k) f propsObj + PFlag b -> + unsafeSetProp k' (toJSBool b) propsObj p <- toJSVal propsObj l <- toJSVal listenersObj @@ -173,49 +233,90 @@ return o -instance (MonadJSM m, Eq a) => Backend (SnabbdomT a) m a where - type VNode (SnabbdomT a) m = SnabVNode +potato :: JSVal -> RawNode -> JSM () +#ifndef ghcjs_HOST_OS +potato n rn = void $ jsg2 "potato" n rn +#else +potato n (RawNode rn) = potato' n rn +foreign import javascript unsafe "window['potato']($1,$2)" potato' :: JSVal -> JSVal -> JSM () +#endif - interpret :: (m ~> JSM) -> Html (SnabbdomT a m) a -> SnabbdomT a m SnabVNode - interpret toJSM = \case - TextNode t -> liftJSM $ fromJSValUnchecked =<< toJSVal t +vnode :: Text -> Object -> [SnabVNode] -> JSM SnabVNode +#ifndef ghcjs_HOST_OS +vnode name o cs = SnabVNode <$> jsg3 "vnode" name o cs +#else +vnode t o cs = join $ vnode' <$> pure t <*> pure o <*> toJSVal cs +foreign import javascript unsafe "window['vnode']($1,$2,$3)" vnode' :: Text -> Object -> JSVal -> JSM SnabVNode +#endif - Node name ps [TextNode t] -> do - i <- ask; liftJSM $ do - o <- props toJSM i ps - fromJSValUnchecked =<< jsg3 "vnode" name o t - Node name ps children -> do - i <- ask; liftJSM $ do - o <- props toJSM i ps - traverse ((toJSM . runSnabbdom i) . interpret toJSM >=> toJSVal) children - >>= jsg3 "vnode" name o >>= fromJSValUnchecked +#ifndef ghcjs_HOST_OS +vnodePotato :: Object -> JSM SnabVNode +vnodePotato o = SnabVNode <$> jsg2 "vnode" "div" o +#else +foreign import javascript unsafe "window['vnode']('div',$1)" vnodePotato :: Object -> JSM SnabVNode +#endif - Potato mrn -> liftJSM $ do - o <- create - hook <- create - rn <- mrn - ins <- toJSVal =<< function (\_ _ -> \case - [n] -> void $ jsg2 "potato" n rn - _ -> return ()) - unsafeSetProp "insert" ins hook - hoo <- toJSVal hook - unsafeSetProp "hook" hoo o - fromJSValUnchecked =<< jsg2 "vnode" "div" o +patchh :: JSVal -> SnabVNode -> JSM () +#ifndef ghcjs_HOST_OS +patchh previousNode newNode = void $ jsg2 "patchh" previousNode newNode +#else +patchh p (SnabVNode n) = patchh' p n +foreign import javascript unsafe "window['patchh']($1,$2)" patchh' :: JSVal -> JSVal -> JSM () +#endif + +instance (MonadJSM m, NFData a) => Backend (SnabbdomT a) m a where + type VNode (SnabbdomT a) m = SnabVNode + + interpret :: (m ~> JSM) -> Html (SnabbdomT a m) a -> SnabbdomT a m SnabVNode + interpret toJSM (Html h') = h' mkNode mkPotato mkText + where + mkNode name ps children = do + i <- snabbAsk; liftJSM $ do + !o <- props toJSM i $ toProps ps + !cs <- toJSM . runSnabbdom i $ sequence children + vnode name o cs + + mkPotato mrn = snabbAsk >>= \i -> liftJSM $ do + o <- create + hook <- create + (rn, stm) <- mrn + ins <- toJSVal =<< function (\_ _ -> \case + [n] -> potato n rn + _ -> return ()) + unsafeSetProp "insert" ins hook + hoo <- toJSVal hook + unsafeSetProp "hook" hoo o + let go = atomically stm >>= writeUpdate i . hoist (toJSM . runSnabbdom i) >> go + void $ forkIO go + vnodePotato o + + mkText = liftJSM . fmap SnabVNode . valMakeText + + patch :: RawNode -> Maybe SnabVNode -> SnabVNode -> SnabbdomT a m SnabVNode - patch (RawNode r) f t = t <$ (liftJSM . void $ jsg2 "patchh" f' t) - where f' = maybe r unVNode f + patch (RawNode container) mPreviousNode newNode = liftJSM $ newNode <$ patchh previousNode newNode + where previousNode = maybe container unVNode mPreviousNode setup :: JSM () -> JSM () setup cb = do void $ eval @Text $(embedStringFile "Shpadoinkle/Backend/Snabbdom/Setup.js") - void . jsg1 "startApp" . fun $ \_ _ _ -> cb + startApp cb +startApp :: JSM () -> JSM () +#ifndef ghcjs_HOST_OS +startApp cb = void . jsg1 "startApp" . fun $ \_ _ _ -> cb +#else +startApp cb = startApp' =<< toJSVal =<< function (fun $ \_ _ _ -> cb) +foreign import javascript unsafe "window['startApp']($1)" startApp' :: JSVal -> JSM () +#endif + + -- | Get the @window.container@ DOM node produced by 'setup' (@Setup.js@). stage :: MonadJSM m => SnabbdomT a m RawNode stage = liftJSM $ do @@ -223,6 +324,8 @@ elm <- createElement doc ("div" :: Text) setAttribute elm ("id" :: Text) ("stage" :: Text) b <- getBodyUnsafe doc + setInnerHTML b "" _ <- appendChild b elm RawNode <$> toJSVal elm +{-# SPECIALIZE stage :: SnabbdomT a JSM RawNode #-} 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 @@ -1,33 +1,22 @@ -(() => { - -const head = document.getElementsByTagName('head')[0]; -const addScript = x => { - const s = document.createElement('script'); - s.type = 'text/javascript'; - s.src = x; - head.appendChild(s); -} - -const cdnjs = x => "https://cdnjs.cloudflare.com/ajax/libs/snabbdom/0.7.4/" + x; - -addScript(cdnjs("snabbdom.min.js")); -addScript(cdnjs("snabbdom-class.min.js")); -addScript(cdnjs("snabbdom-props.min.js")); -addScript(cdnjs("snabbdom-attributes.min.js")); -addScript(cdnjs("snabbdom-eventlisteners.min.js")); -addScript(cdnjs("h.min.js")); - -window.startApp = cb => setTimeout(() => { - const patch = snabbdom.init([ - snabbdom_props.default, - snabbdom_class.default, - snabbdom_attributes.default, - snabbdom_eventlisteners.default - ]); - window.patchh = (a,b) => patch(a,b); - window.vnode = h.default; - window.potato = (n, e) => n.elm.appendChild(e) - cb(); -}, 1000); - -})(); +parcelRequire=function(e,r,t,n){var i,o="function"==typeof parcelRequire&&parcelRequire,u="function"==typeof require&&require;function f(t,n){if(!r[t]){if(!e[t]){var i="function"==typeof parcelRequire&&parcelRequire;if(!n&&i)return i(t,!0);if(o)return o(t,!0);if(u&&"string"==typeof t)return u(t);var c=new Error("Cannot find module '"+t+"'");throw c.code="MODULE_NOT_FOUND",c}p.resolve=function(r){return e[t][1][r]||r},p.cache={};var l=r[t]=new f.Module(t);e[t][0].call(l.exports,p,l,l.exports,this)}return r[t].exports;function p(e){return f(p.resolve(e))}}f.isParcelRequire=!0,f.Module=function(e){this.id=e,this.bundle=f,this.exports={}},f.modules=e,f.cache=r,f.parent=o,f.register=function(r,t){e[r]=[function(e,r){r.exports=t},{}]};for(var c=0;c0?c:s.length,y=m>0?m:s.length,k=-1!==c||-1!==m?s.slice(0,Math.min(g,y)):s,b=e.elm=i(v)&&i(d=v.ns)?h.createElementNS(d,k,v):h.createElement(k,v);for(g0&&b.setAttribute("class",s.slice(y+1).replace(/\./g," ")),d=0;ds?y(e,null==r[m+1]?null:r[m+1].elm,r,f,m,n):b(e,t,v,s))}(c,m,g,r):i(g)?(i(e.text)&&h.setTextContent(c,""),y(c,null,g,0,g.length-1,r)):i(m)?b(c,m,0,m.length-1):i(e.text)&&h.setTextContent(c,""):e.text!==t.text&&(i(m)&&b(c,m,0,m.length-1),h.setTextContent(c,t.text)),null===(f=null==s?void 0:s.postpatch)||void 0===f||f.call(s,e,t)}}return function(t,r){var n,l,o,i=[];for(n=0;n