diff --git a/Shpadoinkle-backend-pardiff.cabal b/Shpadoinkle-backend-pardiff.cabal --- a/Shpadoinkle-backend-pardiff.cabal +++ b/Shpadoinkle-backend-pardiff.cabal @@ -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: 4bcd76a2e9419355d33aae706d474880945952e91a1f339a3389fac24504e3c6 +-- hash: 65bf612b26ecbea7748a26af6eaae7c8a8bbc7881799e4b2cda9908e4e8793ae name: Shpadoinkle-backend-pardiff -version: 0.2.0.0 +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 @@ -37,18 +37,17 @@ , base >=4.12.0 && <4.16 , compactable >=0.1.2 && <0.2 , containers >=0.6.0 && <0.7 + , exceptions , 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 - , neat-interpolation >=0.3.2 && <0.6 , 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 - , uuid >=1.3.13 && <1.4 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 @@ -9,14 +9,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -49,30 +45,47 @@ ) where -import Control.Applicative -import Control.Compactable -import Control.Lens -import Control.Monad.Base -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Data.Align -import Data.Foldable -import Data.Kind +import Control.Applicative (Alternative) +import Control.Compactable (Compactable (traverseMaybe)) +import Control.Lens ((^.)) +import Control.Monad.Base (MonadBase (..), liftBaseDefault) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Reader (MonadIO, MonadReader (ask), + MonadTrans (..), ReaderT (..), + guard, void) +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl, + defaultLiftBaseWith, + defaultRestoreM) +import Data.Align (Semialign (align)) +import Data.Foldable (traverse_) +import Data.Kind (Type) 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 (JSM, MonadJSM, ( # )) -import NeatInterpolation -import System.Random -import UnliftIO +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), + Object, ToJSString (toJSString), + ToJSVal (toJSVal), eval, fun, js1, + js2, jsg, jsg2, liftJSM, + strictEqual, unsafeGetProp, + unsafeSetProp) +import UnliftIO (MonadUnliftIO (..), TVar, + UnliftIO (UnliftIO, unliftIO), + withUnliftIO) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.STM (STM, atomically) -import Shpadoinkle hiding (h, name, props, text) +import Shpadoinkle (Backend (..), Continuation, + Html (..), JSM, MonadJSM, + Prop (..), RawEvent (RawEvent), + RawNode (RawNode), hoist, + type (~>), writeUpdate) default (Text) @@ -88,6 +101,8 @@ , MonadReader (TVar model) , MonadTrans , MonadTransControl + , MonadThrow + , MonadCatch ) @@ -136,15 +151,22 @@ ParTextNode _ t -> "ParTextNode _ " <> show t -data ParVProp a = ParVText Text | ParVListen UUID (RawNode -> RawEvent -> JSM (Continuation JSM a)) | ParVFlag Bool - deriving (Generic) +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 instance Show (ParVProp a) where show = \case - ParVText t -> "ParVText " <> show t - ParVListen u _ -> "ParVListen " <> show u <>" _" - ParVFlag b -> "ParVFlag " <> show b + ParVData _ -> "ParVData _" + ParVPotato _ -> "ParVPotato _" + ParVText t -> "ParVText " <> show t + ParVListen _ -> "ParVListen _" + ParVFlag b -> "ParVFlag " <> show b props :: Monad m => (m ~> JSM) -> TVar a -> Map Text (Prop (ParDiffT a m) a) -> RawNode -> JSM () @@ -155,6 +177,8 @@ prop :: Monad m => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM () prop toJSM i raw k = \case + PData d -> setProp' raw k d + 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 @@ -171,6 +195,14 @@ if b then return () else unsafeSetProp (toJSString k) t' raw' +setProptado :: forall a. TVar a -> (RawNode -> JSM (STM (Continuation JSM a))) -> Object -> JSM () +setProptado i f o = do + elm <- RawNode <$> toJSVal o + stm <- f elm + let go = atomically stm >>= writeUpdate i >> go + void $ forkIO go + + setListener :: TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> Text -> JSM () setListener i m o k = do elm <- RawNode <$> toJSVal o @@ -206,21 +238,21 @@ makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT 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 -> hoist (toJSM . runParDiff i) <$> m x y + 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 setup' :: JSM () -> JSM () setup' cb = do - void $ eval @Text [text| - window.deleteProp = (k, obj) => { - delete obj[k] - } - window.container = document.createElement('div') - document.body.appendChild(container) - |] + void $ eval $ intercalate "\n" + [ " window.deleteProp = (k, obj) => {" + , " delete obj[k]" + , " }" + , " window.container = document.createElement('div')" + , " document.body.appendChild(container)" + ] cb @@ -263,6 +295,8 @@ "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 @@ -276,9 +310,10 @@ (ParVFlag t') | t /= t' -> setFlag obj' k t' -- new listener, 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 + 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 ()