Shpadoinkle-backend-pardiff (empty) → 0.0.0.1

raw patch · 6 files changed

+506/−0 lines, 6 filesdep +Shpadoinkledep +basedep +compactable

Dependencies added: Shpadoinkle, base, compactable, containers, file-embed, jsaddle, lens, mtl, neat-interpolation, random, semialign, text, these, unliftio, uuid

Files

CHANGELOG.md +0/−0
Data/Once.hs +19/−0
LICENSE +26/−0
README.md +20/−0
Shpadoinkle-backend-pardiff.cabal +51/−0
Shpadoinkle/Backend/ParDiff.hs +390/−0

+ CHANGELOG.md view

+ Data/Once.hs view

@@ -0,0 +1,19 @@+module Data.Once (Once, newOnce, runOnce) where+++import           Control.Concurrent.MVar+import           Control.Monad+import           Control.Monad.IO.Class+++newtype Once m a = Once (MVar (m a))+++newOnce :: MonadIO m => m a -> m (Once m a)+newOnce = liftIO . fmap Once . newMVar+++runOnce :: MonadIO m => Once m a -> m a+runOnce (Once io) = do+  x <- join (liftIO $ takeMVar io)+  x <$ liftIO (putMVar io (return x))

+ LICENSE view

@@ -0,0 +1,26 @@+Shpadoinkle ParDiff, 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.+

+ README.md view

@@ -0,0 +1,20 @@+# Shpadoinkle Backend ParDiff++[![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-backend-pardiff.svg)](https://hackage.haskell.org/package/Shpadoinkle-backend-pardiff)+[![Hackage Deps](https://img.shields.io/hackage-deps/v/Shpadoinkle-backend-pardiff.svg)](http://packdeps.haskellers.com/reverse/Shpadoinkle-backend-pardiff)+[![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/Shpadoinkle-backend-pardiff/badge)](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-backend-pardiff)+++Shpadoinkle's ParDiff backend is a virtual dom diffing system written in pure Haskell.+It currently serves as the canonical backend for Shpadoinkle, such that the behavior of+other backends should conform.++The virtual tree in ParDiff contains a reference to the `RawNode` for each element. Merging+unkeyed and keyed virtual dom techniques together. This allows for rendering to be performed+in a keyed fashion for all nodes, while not requiring additional memory or developer overhead.++The diffing itself is a lawful usage of `alignWith` from the `Data.These` package. By modeling+Html as an Alignable Functor, we get principled diffing with clear separation of concerns.++IO is done via JSaddle and works with both GHC and GHCjs.

+ Shpadoinkle-backend-pardiff.cabal view

@@ -0,0 +1,51 @@+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: 7e61e4a4b8473ee552828baa764b2eb324a5a04f9f03caaaf2111c0a346f9127++name:           Shpadoinkle-backend-pardiff+version:        0.0.0.1+synopsis:       A Virtual Dom in pure Haskell, based on Html as an Alignable Functor.+description:    Virtual Dom diffing in pure Haskell. The Diffing is a lawful usage of @alignWith@ from the @Data.These@ package. This implimentation stores a reference to the @RawNode@ for each node in the virtual tree, merging keyed and unkeyed virtual dom techniques.+category:       Web+author:         Isaac Shapira+maintainer:     fresheyeball@protonmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/fresheyeball/Shpadoinkle.git++library+  exposed-modules:+      Shpadoinkle.Backend.ParDiff+  other-modules:+      Data.Once+  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 >=0.0.0 && <0.1+    , base >=4.12.0 && <4.13+    , compactable >=0.1.2 && <0.2+    , containers >=0.6.0 && <0.7+    , file-embed >=0.0.11 && <0.1+    , jsaddle >=0.9.7 && <0.20+    , lens >=4.17.1 && <4.18+    , mtl >=2.2.2 && <2.3+    , neat-interpolation >=0.3.2 && <0.4+    , random >=1.1 && <1.2+    , semialign >=1 && <1.1+    , text >=1.2.3 && <1.3+    , these >=1.0.1 && <1.1+    , unliftio >=0.2.12 && <0.3+    , uuid >=1.3.13 && <1.4+  default-language: Haskell2010

+ Shpadoinkle/Backend/ParDiff.hs view

@@ -0,0 +1,390 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE ExtendedDefaultRules       #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE ViewPatterns               #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++#ifndef ghcjs_HOST_OS+{-# LANGUAGE StandaloneDeriving         #-}+#endif+++{-|+   This backend is to serve as a cannonical representation of a well+   behaved backend. Defining well behaved in the context of web development+   is rather difficult, and complex.++   The rules of a backend are informal. Roughly, if we give the backend+   some Html, we expect it to update the dom at runtime in the way we expect.++   Since this is cannonical, all other backends are expected to behave+   identically to this one. If differences exist they should be patched,+   so that we retain renderer polymorphism. Such that we can change out+   the renderer of our application, without updating the application logic+   with confidence it will behave as expected.+-}+++module Shpadoinkle.Backend.ParDiff+  ( ParDiffT (..)+  , runParDiff+  , stage+  ) where+++import           Control.Applicative+import           Control.Compactable+import           Control.Lens+import           Control.Monad.Reader+import           Data.Align+import           Data.Foldable+import           Data.Kind+import           Data.Map                    (Map)+import qualified Data.Map                    as M+import           Data.Monoid                 ((<>))+import           Data.Once+import           Data.Text+import           Data.These+import           Data.Traversable+import           Data.UUID+import           GHC.Generics+import           Language.Javascript.JSaddle hiding (( # ))+import           NeatInterpolation+import           System.Random+import           UnliftIO++import           Shpadoinkle                 hiding (h, name, props, text)+++default (Text)+++newtype ParDiffT s model m a = ParDiffT { unParDiff :: ReaderT (s model) m a }+  deriving+  ( Functor+  , Applicative+  , Alternative+  , Monad+  , MonadIO+  , MonadReader (s model)+  , MonadTrans+  )+++#ifndef ghcjs_HOST_OS+deriving instance MonadJSM m => MonadJSM (ParDiffT s model m)+#endif+++instance MonadUnliftIO m => MonadUnliftIO (ParDiffT s r m) where+  {-# INLINE askUnliftIO #-}+  askUnliftIO = ParDiffT . ReaderT $ \r ->+                withUnliftIO $ \u ->+                return (UnliftIO (unliftIO u . flip runReaderT r . unParDiff))+  {-# INLINE withRunInIO #-}+  withRunInIO inner =+    ParDiffT . ReaderT $ \r ->+    withRunInIO $ \run' ->+    inner (run' . flip runReaderT r . unParDiff)+++runParDiff :: t model -> ParDiffT t model m ~> m+runParDiff t (ParDiffT r) = runReaderT r t+++data ParVNode :: Type -> Type where+  ParNode     :: Once JSM RawNode -> Text -> Map Text (ParVProp a) -> [ParVNode a] -> ParVNode a+  ParPotato   :: Once JSM RawNode -> ParVNode a+  ParTextNode :: Once JSM RawNode -> Text -> ParVNode a+++instance Show (ParVNode a) where+  show = \case+    ParNode _ t ps cs -> "ParNode _ " <> show t <> " " <> show ps <> " " <> show cs+    ParPotato _       -> "ParPotato _"+    ParTextNode _ t   -> "ParTextNode _ " <> show t+++data ParVProp a = ParVText Text | ParVListen UUID (RawNode -> RawEvent -> JSM a) | ParVFlag Bool+  deriving (Functor, Generic)+++instance Show (ParVProp a) where+  show = \case+    ParVText t     -> "ParVText " <> show t+    ParVListen u _ -> "ParVListen " <> show u <>" _"+    ParVFlag b     -> "ParVFlag " <> show b+++props :: Territory s => (m ~> JSM) -> s a -> Map Text (Prop (ParDiffT s a m) a) -> RawNode -> JSM ()+props toJSM i ps (RawNode raw) = do+  raw' <- makeObject raw+  void . traverse (uncurry $ prop toJSM i raw') $ M.toList ps+++prop :: Territory s => (m ~> JSM) -> s a -> Object -> Text -> Prop (ParDiffT s a m) a -> JSM ()+prop toJSM i raw k = \case+  PText t     -> setProp' raw k t+  PListener f -> setListener i (\x y -> toJSM . runParDiff i $ f x y) raw k+  PFlag True  -> setProp' raw k =<< toJSVal True+  PFlag False -> return ()+++setProp' :: ToJSVal t => Object -> Text -> t -> JSM ()+setProp' raw' k t = do+  let k' = toJSString k+  old <- unsafeGetProp k' raw'+  t' <- toJSVal t+  b <- strictEqual old t'+  if b then return () else unsafeSetProp (toJSString k) t' raw'+++setListener :: Territory s => s a -> (RawNode -> RawEvent -> JSM a) -> Object -> Text -> JSM ()+setListener i m o k = do+  elm <- RawNode <$> toJSVal o+  setProp' o ("on" <> k) . fun $ \_ _ -> \case+    e:_ -> writeUpdate i . const $ m elm (RawEvent e)+    _ -> return ()+++getRaw :: ParVNode a -> Once JSM RawNode+getRaw = \case+  ParNode mk _ _ _ -> mk+  ParPotato mk     -> mk+  ParTextNode mk _ -> mk+++setRaw :: Once JSM RawNode -> ParVNode a -> ParVNode a+setRaw r = \case+  ParNode _ a b c -> ParNode r a b c+  ParPotato _     -> ParPotato r+  ParTextNode _ a -> ParTextNode r a+++appendChild :: RawNode -> ParVNode a -> JSM (ParVNode a)+appendChild (RawNode raw) pn = do+  let raw' = getRaw pn+  RawNode r <- runOnce raw'+  void $ raw ^. js1 "appendChild" r+  return pn+++makeProp :: (m ~> JSM) -> t a -> Prop (ParDiffT t a m) a -> JSM (ParVProp a)+makeProp toJSM i = \case+  PText t     -> return $ ParVText t+  PListener m -> do+    u <- liftIO randomIO+    return . ParVListen u $ \x y -> toJSM . runParDiff i $ m x y+  PFlag b     -> return $ ParVFlag b+++setup' :: MonadJSM m => JSM () -> ParDiffT s a m ()+setup' cb = liftJSM $ do+  void $ eval @Text [text|+      window.deleteProp = (k, obj) => {+        delete obj[k]+      }+      window.container = document.createElement('div')+      document.body.appendChild(container)+    |]+  liftJSM cb+++voidJSM :: MonadJSM m => JSM a -> m ()+voidJSM = void . liftJSM+++setFlag :: MonadJSM m => Object -> Text -> Bool -> m ()+setFlag obj' k b = if b then+    voidJSM $ setProp' obj' k =<< toJSVal True+  else case k of+    "checked"  -> voidJSM $ setProp' obj' k =<< toJSVal False+    "disabled" -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"+    _          -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'+++managePropertyState :: Territory s => MonadJSM m => s a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m ()+managePropertyState i obj' old new' = void $+  M.toList (align old new') `for` \(k, x) -> case x of+    -- only old had it, delete+    This _                 -> case k of+      "className" -> voidJSM $ obj' ^. js1 "removeAttribute" "class"+      "htmlFor"   -> voidJSM $ obj' ^. js1 "removeAttribute" "for"+      "style"     -> voidJSM $ obj' ^. js1 "removeAttribute" "style"+      "checked"   -> voidJSM $ setProp' obj' k =<< toJSVal False+      "disabled"  -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"+      _           -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'+    -- new text prop, set+    That  (ParVText t)     -> voidJSM $ setProp' obj' k =<< toJSVal t+    -- changed text prop, set+    These (ParVText t)+          (ParVText t')+                | t /= t'  -> voidJSM $ setProp' obj' k =<< toJSVal t'+    -- new flag prop, set+    That  (ParVFlag b)  -> setFlag obj' k b+    -- changed flag prop, set+    These (ParVFlag t)+          (ParVFlag t')+                | t /= t' -> setFlag obj' k t'+    -- new listner, set+    That  (ParVListen _ h) -> voidJSM $ setListener i h obj' k+    -- changed listener, set+    These (ParVListen u _) (ParVListen u' h) | u /= u' -> voidJSM $ setListener i h obj' k+    -- no change, do nothing+    These _ _              -> return ()+++patchChildren+  :: MonadUnliftIO m+#ifndef ghcjs_HOST_OS+  => MonadJSM m+#endif+  => Show a+  => Territory s+  => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT s a m [ParVNode a]+patchChildren parent@(RawNode p) old new'' =+  traverseMaybe (\case++    This child -> do+      RawNode c <- lift . liftJSM . runOnce $ getRaw child+      voidJSM $ p ^. js1 "removeChild" c+      return Nothing++    That child -> do+      RawNode c <- lift . liftJSM . runOnce $ getRaw child+      voidJSM $ p ^. js1 "appendChild" c+      return $ Just child++    These old' new' ->+      Just <$> patch' parent (Just old') new'++  ) (align old new'')+++patch'+  :: MonadUnliftIO m+#ifndef ghcjs_HOST_OS+  => MonadJSM m+#endif+  => Show a+  => Territory s+  => RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT s a m (ParVNode a)+patch' parent old new' = do+  i <- ask+  case (old, new') of++    -- text node did not change+    (Just old'@(ParTextNode _ t)+              , ParTextNode _ t')+                         | t == t' -> return old'+++    -- text node changed+    (Just (ParTextNode raw _)+         , ParTextNode _ t) -> do++      RawNode r <- liftJSM $ runOnce raw+      obj' <- liftJSM $ makeObject r+      liftJSM $ setProp' obj' "nodeValue" =<< toJSVal t+      return $ setRaw raw new'+++    -- node may have changed+    (Just (ParNode raw name ps cs)+         , ParNode _   name' ps' cs')+                 | name == name' -> do++      raw'@(RawNode r) <- liftJSM $ runOnce raw+      obj' <- liftJSM $ makeObject r+      managePropertyState i obj' ps ps'+      cs'' <- patchChildren raw' cs cs'+      return $ ParNode raw name ps' cs''+++    -- node definately has changed+    (Just old', _) -> do++      RawNode p <- return parent+      RawNode r <- lift . liftJSM . runOnce $ getRaw old'+      RawNode c <- lift . liftJSM . runOnce $ getRaw new'+      _ <- liftJSM $ p ^. js2 "replaceChild" c r+      return new'+++    -- first patch+    (Nothing, _) -> do++      RawNode p <- return parent+      RawNode c <- lift . liftJSM . runOnce $ getRaw new'+      _ <- liftJSM $ p ^. js1 "appendChild" c+      return new'+++interpret'+  :: MonadJSM m+  => MonadUnliftIO m+  => Eq a+  => Show a+  => Territory s+  => (m ~> JSM) -> Html (ParDiffT s a m) a -> ParDiffT s a m (ParVNode a)+interpret' toJSM = \case++  TextNode t -> do+    raw <- liftJSM . newOnce $ do+      doc <- jsg "document"+      RawNode <$> doc ^. js1 "createTextNode" t+    return $ ParTextNode raw t++  Potato p -> do+    raw <- liftJSM $ newOnce p+    return $ ParPotato raw++  Node name (M.fromList -> ps) cs -> do+    i <- ask++    let makeNode = do+          doc <- jsg "document"+          elm <- RawNode <$> doc ^. js1 "createElement" name+          props toJSM i ps elm+          return elm++    cs' <- traverse (interpret toJSM) cs+    raw <- liftJSM . newOnce $ do+      node <- makeNode+      traverse_ (appendChild node) cs'+      return node++    p <- liftJSM $ makeProp toJSM i `traverse` ps++    return $ ParNode raw name p cs'+++instance+  ( MonadUnliftIO m+  , MonadJSM m+  , Eq a+  , Show a+  , Territory t ) => Backend (ParDiffT t a) m a where+  type VNode (ParDiffT t a) m = ParVNode a+  interpret = interpret'+  setup = setup'+  patch = patch'+++stage :: FromJSVal b => MonadJSM m => ParDiffT s a m b+stage = liftJSM $ fromJSValUnchecked =<< jsg "container"