Shpadoinkle-backend-pardiff 0.2.0.0 → 0.3.0.0

raw patch · 2 files changed

+81/−47 lines, 2 filesdep +exceptionsdep −neat-interpolationdep −uuidPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependencies removed: neat-interpolation, uuid

API changes (from Hackage documentation)

Files

• Shpadoinkle-backend-pardiff.cabal +4/−5
• Shpadoinkle/Backend/ParDiff.hs +77/−42

@@ -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

@@ -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 ()