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 ParDiff -[![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-pardiff) [![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) diff --git a/Shpadoinkle-backend-pardiff.cabal b/Shpadoinkle-backend-pardiff.cabal --- a/Shpadoinkle-backend-pardiff.cabal +++ b/Shpadoinkle-backend-pardiff.cabal @@ -1,37 +1,46 @@ -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: 65bf612b26ecbea7748a26af6eaae7c8a8bbc7881799e4b2cda9908e4e8793ae - -name: Shpadoinkle-backend-pardiff -version: 0.3.0.0 -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 implementation 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 +cabal-version: 2.2 +name: Shpadoinkle-backend-pardiff +version: 0.3.0.1 +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 + README.md +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 implementation stores a + reference to the @RawNode@ for each node in the virtual tree, merging + keyed and unkeyed virtual DOM techniques. + source-repository head type: git - location: https://gitlab.com/fresheyeball/Shpadoinkle.git + location: https://gitlab.com/platonic/shpadoinkle.git + library exposed-modules: - Shpadoinkle.Backend.ParDiff + 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 + 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 , base >=4.12.0 && <4.16 @@ -41,13 +50,11 @@ , file-embed >=0.0.11 && <0.1 , ghcjs-dom >=0.9.4 && <0.20 , jsaddle >=0.9.7 && <0.20 - , lens >=4.17.1 && <5.0 , monad-control >=1.0.2 && <1.1 , mtl >=2.2.2 && <2.3 , random >=1.1 && <1.3 - , semialign >=1 && <1.2 , text >=1.2.3 && <1.3 - , these >=1 && <1.2 , transformers-base >=0.4.5 && <0.5 , unliftio >=0.2.12 && <0.3 + default-language: Haskell2010 diff --git a/Shpadoinkle/Backend/ParDiff.hs b/Shpadoinkle/Backend/ParDiff.hs --- a/Shpadoinkle/Backend/ParDiff.hs +++ b/Shpadoinkle/Backend/ParDiff.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -14,7 +14,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} #ifndef ghcjs_HOST_OS @@ -46,35 +45,36 @@ import Control.Applicative (Alternative) -import Control.Compactable (Compactable (traverseMaybe)) -import Control.Lens ((^.)) +import Control.Monad (forM_, void, when) 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.RWS (MonadRWS) import Control.Monad.Reader (MonadIO, MonadReader (ask), MonadTrans (..), ReaderT (..), - guard, void) + guard) +import Control.Monad.State (MonadState) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl, defaultLiftBaseWith, defaultRestoreM) -import Data.Align (Semialign (align)) -import Data.Foldable (traverse_) +import Control.Monad.Writer (MonadWriter) import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as M +import Data.Map.Internal (Map (Bin, Tip)) +import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Once (Once, newOnce, runOnce) import Data.Text (Text, intercalate) -import Data.These (These (That, These, This)) -import Data.Traversable (for) -import GHC.Generics (Generic) import Language.Javascript.JSaddle (FromJSVal (fromJSValUnchecked), - JSVal, MakeObject (makeObject), + JSString, MakeObject (makeObject), Object, ToJSString (toJSString), - ToJSVal (toJSVal), eval, fun, js1, - js2, jsg, jsg2, liftJSM, - strictEqual, unsafeGetProp, - unsafeSetProp) + ToJSVal (toJSVal), eval, fun, + jsFalse, jsTrue, jsg, jsg2, + liftJSM, unsafeSetProp, + valMakeText, (#)) import UnliftIO (MonadUnliftIO (..), TVar, UnliftIO (UnliftIO, unliftIO), withUnliftIO) @@ -82,10 +82,12 @@ import UnliftIO.STM (STM, atomically) import Shpadoinkle (Backend (..), Continuation, - Html (..), JSM, MonadJSM, - Prop (..), RawEvent (RawEvent), - RawNode (RawNode), hoist, - type (~>), writeUpdate) + Html (..), JSM, MonadJSM, NFData, + Prop (..), Props (..), + RawEvent (RawEvent), + RawNode (RawNode, unRawNode), + hoist, toProps, type (~>), + writeUpdate) default (Text) @@ -103,6 +105,12 @@ , MonadTransControl , MonadThrow , MonadCatch + , MonadMask + , MonadWriter w + , MonadState s + , MonadRWS (TVar model) w s + , MonadError e + , MonadCont ) @@ -139,63 +147,36 @@ data ParVNode :: Type -> Type where - ParNode :: Once JSM RawNode -> Text -> Map Text (ParVProp a) -> [ParVNode a] -> ParVNode a + ParNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVProps 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 - | ParVData JSVal - | ParVListen (RawNode -> RawEvent -> JSM (Continuation JSM a)) - | ParVFlag Bool - | ParVPotato (RawNode -> JSM (STM (Continuation JSM a))) - deriving Generic + ParTextNode :: Once JSM RawNode -> {-# UNPACK #-} !Text -> ParVNode a +type ParVProps = Props JSM -instance Show (ParVProp a) where - show = \case - ParVData _ -> "ParVData _" - ParVPotato _ -> "ParVPotato _" - ParVText t -> "ParVText " <> show t - ParVListen _ -> "ParVListen _" - ParVFlag b -> "ParVFlag " <> show b +type ParVProp = Prop JSM -props :: Monad m => (m ~> JSM) -> TVar a -> Map Text (Prop (ParDiffT a m) a) -> RawNode -> JSM () -props toJSM i ps (RawNode raw) = do +props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (ParDiffT a m) a -> RawNode -> JSM () +props toJSM i (Props ps) (RawNode raw) = do raw' <- makeObject raw - void . traverse (uncurry $ prop toJSM i raw') $ M.toList ps + traverseWithKey_ (prop toJSM i raw') ps -prop :: Monad m => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM () +prop :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM () prop toJSM i raw k = \case - PData d -> setProp' raw k d + PData d -> unsafeSetProp k' d raw + PText t -> do + t' <- valMakeText t + unsafeSetProp k' t' raw PPotato p -> setProptado i (fmap (fmap (hoist (toJSM . runParDiff i))) . p) raw - PText t -> setProp' raw k t - PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i) - <$> f x y) raw k - PFlag True -> setProp' raw k =<< toJSVal True + PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i) <$> f x y) raw k' + PFlag True -> unsafeSetProp k' jsTrue raw 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' + where + k' = toJSString k -setProptado :: forall a. TVar a -> (RawNode -> JSM (STM (Continuation JSM a))) -> Object -> JSM () +setProptado :: forall a. NFData a => TVar a -> (RawNode -> JSM (STM (Continuation JSM a))) -> Object -> JSM () setProptado i f o = do elm <- RawNode <$> toJSVal o stm <- f elm @@ -203,14 +184,15 @@ void $ forkIO go -setListener :: TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> Text -> JSM () +setListener :: NFData a => TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> JSString -> JSM () setListener i m o k = do elm <- RawNode <$> toJSVal o - setProp' o ("on" <> k) . fun $ \_ _ -> \case + f <- toJSVal . fun $ \_ _ -> \case e:_ -> do x <- m elm (RawEvent e) writeUpdate i x _ -> return () + unsafeSetProp ("on" <> k) f o getRaw :: ParVNode a -> Once JSM RawNode @@ -220,28 +202,13 @@ 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 :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> JSM (ParVProp a) +makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> ParVProp a makeProp toJSM i = \case - PText t -> return $ ParVText t - PData t -> return $ ParVData t - PPotato p -> return . ParVPotato $ fmap (fmap (hoist (toJSM . runParDiff i))) . p - PListener m -> return . ParVListen $ \x y -> hoist (toJSM . runParDiff i) <$> m x y - PFlag b -> return $ ParVFlag b + PText t -> PText t + PData t -> PData t + PPotato p -> PPotato $ fmap (fmap (hoist (toJSM . runParDiff i))) . p + PListener m -> PListener $ \x y -> hoist (toJSM . runParDiff i) <$> m x y + PFlag b -> PFlag b setup' :: JSM () -> JSM () @@ -256,21 +223,27 @@ cb -voidJSM :: MonadJSM m => JSM a -> m () -voidJSM = void . liftJSM +setFlag :: Object -> Text -> Bool -> JSM () +setFlag obj' k b + | b = unsafeSetProp k' jsTrue obj' + | otherwise = case k of + "checked" -> unsafeSetProp k' jsFalse obj' + "disabled" -> void (obj' # "removeAttribute" $ "disabled") + _ -> void (jsg2 "deleteProp" k' obj') + where + k' = toJSString k -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' +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 -managePropertyState :: MonadJSM m => TVar a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m () -managePropertyState i obj' old new' = void $ do +managePropertyState :: NFData a => TVar a -> Object -> ParVProps a -> ParVProps a -> JSM () +managePropertyState i obj' (Props !old) (Props !new) = void $ do -- The following step may be necessary if the old DOM and the new VDOM both have checked == False -- but the user just checked this checkbox / radio button and the browser set its -- checked property to true without setting its checked attribute. @@ -284,64 +257,67 @@ -- Of these properties, checked is the only one where we know that the absence of the attribute -- in both the old and new (V)DOMs is consistent with the property needing to be updated -- because the property was updated with the corresponding attribute being absent the whole time. - maybe (return ()) (const . voidJSM $ setProp' obj' "checked" =<< toJSVal False) - $ M.lookup "checked" new' >>= guard . (\case { ParVFlag False -> True; _ -> False }) - 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' - That (ParVPotato p) -> voidJSM $ p . RawNode =<< toJSVal obj' - That (ParVData j) -> voidJSM $ setProp' obj' k j - -- 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 listener, set - That (ParVListen h) -> voidJSM $ setListener i h obj' k - -- listeners are uncomparable in any useful way - These (ParVListen _) - (ParVListen h) -> voidJSM $ setListener i h obj' k - -- no change, do nothing - These _ _ -> return () + let isFalseFlag (PFlag f) = not f + isFalseFlag _ = False + when (isJust (M.lookup "checked" new >>= guard . isFalseFlag)) + (unsafeSetProp "checked" jsFalse obj') + let toRemove = M.difference old new + willInclude new' old' + | new' == old' = Nothing + | otherwise = Just new' + toInclude = M.differenceWith willInclude new old + remove k _ = case k of + "className" -> void $ obj' # "removeAttribute" $ "class" + "href" -> void $ obj' # "removeAttribute" $ "href" + "htmlFor" -> void $ obj' # "removeAttribute" $ "for" + "style" -> void $ obj' # "removeAttribute" $ "style" + "checked" -> unsafeSetProp (toJSString k) jsFalse obj' + "disabled" -> void $ obj' # "removeAttribute" $ "disabled" + _ -> void $ jsg2 "deleteProp" (toJSString k) obj' + + traverseWithKey_ remove toRemove + + let include k v = + let k' = toJSString k + in case v of + PPotato p -> void . p . RawNode =<< toJSVal obj' -- FIXME why throw away continuation...??? + PData j -> unsafeSetProp k' j obj' + -- new text prop, set + PText t -> do + t' <- valMakeText t + unsafeSetProp k' t' obj' + -- new flag prop, set + PFlag b -> setFlag obj' k b + -- new listener, set + PListener h -> setListener i h obj' k' + + traverseWithKey_ include toInclude + + patchChildren :: MonadUnliftIO m #ifndef ghcjs_HOST_OS => MonadJSM m #endif => Show a + => NFData a => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT 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'') +patchChildren (RawNode p) [] new = liftJSM $ do + forM_ new $ \newChild -> do + RawNode cRaw <- runOnce (getRaw newChild) + p # "appendChild" $ cRaw + pure new +patchChildren _ old [] = liftJSM $ do + doc <- jsg "document" + tmp <- doc # "createElement" $ "div" + old' <- traverse (fmap unRawNode . runOnce . getRaw) old + void (tmp # "replaceChildren" $ old') + void (tmp # "remove" $ ()) + pure [] +patchChildren parent (old:olds) (new:news) = + (:) <$> patch' parent old new <*> patchChildren parent olds news patch' @@ -350,105 +326,102 @@ => MonadJSM m #endif => Show a - => RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT a m (ParVNode a) -patch' parent old new' = do + => NFData a + => RawNode -> ParVNode a -> ParVNode a -> ParDiffT 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' + case (old, new) of + (ParTextNode raw t', ParTextNode _ t) + -- text node did not change + | t == t' -> return old + -- text node changed + | otherwise -> liftJSM $ do + RawNode r <- runOnce raw + obj' <- makeObject r + tNew <- valMakeText t + unsafeSetProp "nodeValue" tNew obj' + return (ParTextNode raw t) -- 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'' - + (ParNode raw name ps cs, ParNode _ name' ps' cs') + | name == name' -> do + raw' <- liftJSM $ do + RawNode r <- runOnce raw + obj' <- makeObject r + managePropertyState i obj' ps ps' + pure (RawNode r) + cs'' <- patchChildren raw' cs cs' + return $ ParNode raw name ps' cs'' -- node definitely 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' + _ -> liftJSM $ do + let RawNode p = parent + RawNode r <- runOnce $ getRaw old + RawNode c <- runOnce $ getRaw new + _ <- p # "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' - +{-# SPECIALIZE interpret' :: forall a. NFData a => (JSM ~> JSM) -> Html (ParDiffT a JSM) a -> ParDiffT a JSM (ParVNode a) #-} interpret' - :: MonadJSM m - => MonadUnliftIO m - => Eq a - => Show a + :: forall m a + . MonadJSM m + => NFData a => (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT 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 +interpret' toJSM (Html h') = h' mkNode mkPotato mkText + where + mkNode :: Text -> [(Text, Prop (ParDiffT a m) a)] -> [ParDiffT a m (ParVNode a)] -> ParDiffT a m (ParVNode a) + mkNode name ps cs = do + cs' <- sequence cs + i <- ask + let ps' = toProps ps + raw <- liftJSM . newOnce $ do + doc <- jsg "document" + raw' <- doc # "createElement" $ name + props toJSM i ps' (RawNode raw') + forM_ cs' $ \c -> do + RawNode cRaw <- runOnce (getRaw c) + raw' # "appendChild" $ cRaw + return (RawNode raw') - let makeNode = do - doc <- jsg "document" - elm <- RawNode <$> doc ^. js1 "createElement" name - props toJSM i ps elm - return elm + let p = Props (makeProp toJSM i <$> getProps ps') - cs' <- traverse (interpret toJSM) cs - raw <- liftJSM . newOnce $ do - node <- makeNode - traverse_ (appendChild node) cs' - return node + return $ ParNode raw name p cs' - p <- liftJSM $ makeProp toJSM i `traverse` ps + mkPotato :: JSM (RawNode, STM (Continuation (ParDiffT a m) a)) -> ParDiffT a m (ParVNode a) + mkPotato mrn = ask >>= \i -> liftJSM $ do + (rn, stm) <- mrn + let go = atomically stm >>= writeUpdate i . hoist (toJSM . runParDiff i) >> go + void $ forkIO go + fmap ParPotato $ newOnce $ pure rn - return $ ParNode raw name p cs' + mkText :: Text -> ParDiffT a m (ParVNode a) + mkText t = liftJSM $ do + raw <- newOnce $ do + doc <- jsg "document" + RawNode <$> (doc # "createTextNode" $ t) + return $ ParTextNode raw t instance ( MonadUnliftIO m , MonadJSM m - , Eq a + , NFData a , Show a ) => Backend (ParDiffT a) m a where type VNode (ParDiffT a) m = ParVNode a interpret = interpret' setup = setup' - patch = patch' + patch parent mOld new = case mOld of + -- first patch + Nothing -> + liftJSM $ do + let RawNode p = parent + RawNode c <- runOnce (getRaw new) + _ <- p # "appendChild" $ c + return new + Just old -> patch' parent old new -- | Get the DOM node produced by 'setup'.