diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Shpadoinkle Snabbdom, I think I know exactly what it means +Copyright © 2019 Isaac Shpaira +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: +1. Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. +3. Neither the name of the <`3:organization`> nor the +names of its contributors may be used to endorse or promote products +derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +# Shpadoinkle Backend Snabbdom + +[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle) +[![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) +[![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-backend-snabbdom.svg)](https://hackage.haskell.org/package/Shpadoinkle-backend-snabbdom) +[![Hackage Deps](https://img.shields.io/hackage-deps/v/Shpadoinkle-backend-snabbdom.svg)](http://packdeps.haskellers.com/reverse/Shpadoinkle-backend-snabbdom) +[![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/Shpadoinkle-backend-snabbdom/badge)](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-backend-snabbdom) + +This package contains a script to setup the [Snabbdom](https://github.com/snabbdom/snabbdom) virtual dom library as a backend to render Shpadoinkle applications. + +> 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 via [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: + +- 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. + diff --git a/Shpadoinkle-backend-snabbdom.cabal b/Shpadoinkle-backend-snabbdom.cabal new file mode 100644 --- /dev/null +++ b/Shpadoinkle-backend-snabbdom.cabal @@ -0,0 +1,43 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.32.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 65d971f46c65e7bf9238533aaa2d123da99931470b4b1a444c39110f953e032b + +name: Shpadoinkle-backend-snabbdom +version: 0.1.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 made it 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 +extra-source-files: + README.md + CHANGELOG.md + Shpadoinkle/Backend/Snabbdom/Setup.js + +source-repository head + type: git + location: https://gitlab.com/fresheyeball/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 + build-depends: + Shpadoinkle + , base >=4.12.0 && <4.15 + , file-embed >=0.0.11 && <0.1 + , jsaddle >=0.9.7 && <0.20 + , mtl >=2.2.2 && <2.3 + , text >=1.2.3 && <1.3 + default-language: Haskell2010 diff --git a/Shpadoinkle/Backend/Snabbdom.hs b/Shpadoinkle/Backend/Snabbdom.hs new file mode 100644 --- /dev/null +++ b/Shpadoinkle/Backend/Snabbdom.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + + +module Shpadoinkle.Backend.Snabbdom + ( SnabbdomT (..) + , runSnabbdom + , stage + ) where + +import Control.Category +import Control.Monad.Reader +import Data.FileEmbed +import Data.Text +import Data.Traversable +import GHC.Conc +import Language.Javascript.JSaddle hiding (( # )) +import Prelude hiding ((.)) + +import Shpadoinkle hiding (children, name, props) + + +default (Text) + + +newtype SnabVNode = SnabVNode { unVNode :: JSVal } +instance ToJSVal SnabVNode where toJSVal = return . unVNode +instance FromJSVal SnabVNode where fromJSVal = return . Just . SnabVNode + + +newtype SnabbdomT model m a = Snabbdom { unSnabbdom :: ReaderT (TVar model) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader (TVar model), MonadTrans) + + +#ifndef ghcjs_HOST_OS +deriving instance MonadJSM m => MonadJSM (SnabbdomT model m) +#endif + + +runSnabbdom :: TVar model -> SnabbdomT model m a -> m a +runSnabbdom t (Snabbdom r) = runReaderT r t + + +props :: (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 + void $ xs `for` \(k, p) -> case p of + PText t -> do + t' <- toJSVal t + true <- toJSVal True + case k of + "className" | t /= "" -> unsafeSetProp (toJSString t) true c + _ -> unsafeSetProp (toJSString k) t' a + PListener f -> do + f' <- toJSVal . fun $ \_ _ -> \case + [] -> return () + ev:_ -> do + rn <- unsafeGetProp "target" =<< valToObject ev + liftIO . atomically . writeTVar i =<< (toJSM . runSnabbdom i) (f (RawNode rn) (RawEvent ev)) + unsafeSetProp (toJSString k) f' e + PFlag b -> do + f <- toJSVal b + unsafeSetProp (toJSString k) f a + + p <- toJSVal a + l <- toJSVal e + k <- toJSVal c + unsafeSetProp "props" p o + unsafeSetProp "class" k o + unsafeSetProp "on" l o + return o + + +instance (MonadJSM m, Eq 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 = \case + + TextNode t -> liftJSM $ fromJSValUnchecked =<< toJSVal t + + 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 + + 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 + + + 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 + + + setup :: JSM () -> SnabbdomT a m () + setup cb = liftJSM $ do + void $ eval @Text $(embedStringFile "Shpadoinkle/Backend/Snabbdom/Setup.js") + void . jsg1 "startApp" . fun $ \_ _ _ -> cb + + +stage :: MonadJSM m => SnabbdomT a m RawNode +stage = liftJSM $ fromJSValUnchecked =<< jsg "container" + diff --git a/Shpadoinkle/Backend/Snabbdom/Setup.js b/Shpadoinkle/Backend/Snabbdom/Setup.js new file mode 100644 --- /dev/null +++ b/Shpadoinkle/Backend/Snabbdom/Setup.js @@ -0,0 +1,36 @@ +(() => { + +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-style.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) + window.container = document.createElement('div'); + document.body.appendChild(container); + cb(); +}, 1000); + +})();