Shpadoinkle-backend-pardiff 0.1.0.1 → 0.2.0.0

raw patch · 4 files changed

+104/−68 lines, 4 filesdep +ghcjs-domdep +monad-controldep +transformers-basedep ~basedep ~randomdep ~thesePVP ok

version bump matches the API change (PVP)

Dependencies added: ghcjs-dom, monad-control, transformers-base

Dependency ranges changed: base, random, these

API changes (from Hackage documentation)

Files

• LICENSE +21/−20
• README.md +3/−2
• Shpadoinkle-backend-pardiff.cabal +9/−6
• Shpadoinkle/Backend/ParDiff.hs +71/−40

@@ -1,26 +1,27 @@-Shpadoinkle ParDiff, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle ParDiff aka S11 ParDiff+Copyright © 2020 Isaac Shapira 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.+ * Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+ * 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.+ * Neither the name of Shpadoinkle 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 THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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.

@@ -1,6 +1,7 @@ # Shpadoinkle Backend ParDiff  [![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/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) [![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-backend-pardiff.svg)](https://hackage.haskell.org/package/Shpadoinkle-backend-pardiff)@@ -17,6 +18,6 @@ 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.+Html as an Alignable Functor, you get principled diffing with clear separation of concerns. -IO is done via JSaddle and works with both GHC and GHCjs.+IO is done using JSaddle, and works with both GHC and GHCjs.

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 155c49d78360144d64f13cffb9b7fa4809906b5397bdc653a7a62767650db3c1+-- hash: 4bcd76a2e9419355d33aae706d474880945952e91a1f339a3389fac24504e3c6  name:           Shpadoinkle-backend-pardiff-version:        0.1.0.1+version:        0.2.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 implimentation stores a reference to the @RawNode@ for each node in the virtual tree, merging keyed and unkeyed virtual dom techniques.+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@@ -34,18 +34,21 @@   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+    , base >=4.12.0 && <4.16     , compactable >=0.1.2 && <0.2     , containers >=0.6.0 && <0.7     , 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.2+    , random >=1.1 && <1.3     , semialign >=1 && <1.2     , text >=1.2.3 && <1.3-    , these >=1.0.1 && <1.1+    , 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

@@ -12,10 +12,12 @@ {-# 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 #-} @@ -25,17 +27,17 @@   {-|-   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.+   This backend is to serve as a canonical 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.+   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+   Since this is canonical, 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. -} @@ -50,7 +52,9 @@ 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@@ -63,7 +67,7 @@ import           Data.Traversable import           Data.UUID import           GHC.Generics-import           Language.Javascript.JSaddle hiding (( # ))+import           Language.Javascript.JSaddle hiding (JSM, MonadJSM, ( # )) import           NeatInterpolation import           System.Random import           UnliftIO@@ -74,24 +78,35 @@ default (Text)  -newtype ParDiffT s model m a = ParDiffT { unParDiff :: ReaderT (s model) m a }+newtype ParDiffT model m a = ParDiffT { unParDiff :: ReaderT (TVar model) m a }   deriving   ( Functor   , Applicative   , Alternative   , Monad   , MonadIO-  , MonadReader (s model)+  , MonadReader (TVar model)   , MonadTrans+  , MonadTransControl   )   #ifndef ghcjs_HOST_OS-deriving instance MonadJSM m => MonadJSM (ParDiffT s model m)+deriving instance MonadJSM m => MonadJSM (ParDiffT model m) #endif  -instance MonadUnliftIO m => MonadUnliftIO (ParDiffT s r m) where+instance MonadBase n m => MonadBase n (ParDiffT model m) where+  liftBase = liftBaseDefault+++instance MonadBaseControl n m => MonadBaseControl n (ParDiffT model m) where+  type StM (ParDiffT model m) a = ComposeSt (ParDiffT model) m a+  liftBaseWith = defaultLiftBaseWith+  restoreM = defaultRestoreM+++instance MonadUnliftIO m => MonadUnliftIO (ParDiffT r m) where   {-# INLINE askUnliftIO #-}   askUnliftIO = ParDiffT . ReaderT $ \r ->                 withUnliftIO $ \u ->@@ -103,7 +118,8 @@     inner (run' . flip runReaderT r . unParDiff)  -runParDiff :: t model -> ParDiffT t model m ~> m+-- | 'ParDiffT' is a @newtype@ of 'ReaderT', this is the 'runReaderT' equivalent.+runParDiff :: TVar model -> ParDiffT model m ~> m runParDiff t (ParDiffT r) = runReaderT r t  @@ -120,8 +136,8 @@     ParTextNode _ t   -> "ParTextNode _ " <> show t  -data ParVProp a = ParVText Text | ParVListen UUID (RawNode -> RawEvent -> JSM a) | ParVFlag Bool-  deriving (Functor, Generic)+data ParVProp a = ParVText Text | ParVListen UUID (RawNode -> RawEvent -> JSM (Continuation JSM a)) | ParVFlag Bool+  deriving (Generic)   instance Show (ParVProp a) where@@ -131,16 +147,17 @@     ParVFlag b     -> "ParVFlag " <> show b  -props :: Territory s => (m ~> JSM) -> s a -> Map Text (Prop (ParDiffT s a m) a) -> RawNode -> JSM ()+props :: Monad m => (m ~> JSM) -> TVar a -> Map Text (Prop (ParDiffT 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 :: Monad m => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT 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+  PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i)+                                         <$> f x y) raw k   PFlag True  -> setProp' raw k =<< toJSVal True   PFlag False -> return () @@ -154,11 +171,13 @@   if b then return () else unsafeSetProp (toJSString k) t' raw'  -setListener :: Territory s => s a -> (RawNode -> RawEvent -> JSM a) -> Object -> Text -> JSM ()+setListener :: TVar a -> (RawNode -> RawEvent -> JSM (Continuation 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)+    e:_ -> do+      x <- m elm (RawEvent e)+      writeUpdate i x     _ -> return ()  @@ -184,17 +203,17 @@   return pn  -makeProp :: (m ~> JSM) -> t a -> Prop (ParDiffT t a m) a -> JSM (ParVProp a)+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 -> toJSM . runParDiff i $ m x y+    return . ParVListen u $ \x y -> hoist (toJSM . runParDiff i) <$> m x y   PFlag b     -> return $ ParVFlag b  -setup' :: MonadJSM m => JSM () -> ParDiffT s a m ()-setup' cb = liftJSM $ do+setup' :: JSM () -> JSM ()+setup' cb = do   void $ eval @Text [text|       window.deleteProp = (k, obj) => {         delete obj[k]@@ -202,7 +221,7 @@       window.container = document.createElement('div')       document.body.appendChild(container)     |]-  liftJSM cb+  cb   voidJSM :: MonadJSM m => JSM a -> m ()@@ -218,8 +237,23 @@     _          -> 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 $+managePropertyState :: MonadJSM m => TVar a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m ()+managePropertyState i obj' old 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.+  -- As far as we know this issue only occurs with the checked property.+  -- As far as we know this issue only occurs with the value properties of input controls,+  -- which include but are not necessarily limited to:+  --  * The value properties of input, select, and textarea elements+  --  * The checked properties of input type={checkbox,radio} elements+  --  * The src properties of image elements+  --  * The files properties of file elements+  -- 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@@ -241,7 +275,7 @@     These (ParVFlag t)           (ParVFlag t')                 | t /= t' -> setFlag obj' k t'-    -- new listner, set+    -- 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@@ -255,8 +289,7 @@   => MonadJSM m #endif   => Show a-  => Territory s-  => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT s a m [ParVNode a]+  => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a] patchChildren parent@(RawNode p) old new'' =   traverseMaybe (\case @@ -282,8 +315,7 @@   => MonadJSM m #endif   => Show a-  => Territory s-  => RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT s a m (ParVNode a)+  => RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT a m (ParVNode a) patch' parent old new' = do   i <- ask   case (old, new') of@@ -316,7 +348,7 @@       return $ ParNode raw name ps' cs''  -    -- node definately has changed+    -- node definitely has changed     (Just old', _) -> do        RawNode p <- return parent@@ -340,8 +372,7 @@   => MonadUnliftIO m   => Eq a   => Show a-  => Territory s-  => (m ~> JSM) -> Html (ParDiffT s a m) a -> ParDiffT s a m (ParVNode a)+  => (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT a m (ParVNode a) interpret' toJSM = \case    TextNode t -> do@@ -378,13 +409,13 @@   ( 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+  , Show a ) => Backend (ParDiffT a) m a where+  type VNode (ParDiffT a) m = ParVNode a   interpret = interpret'   setup = setup'   patch = patch'  -stage :: FromJSVal b => MonadJSM m => ParDiffT s a m b+-- | Get the DOM node produced by 'setup'.+stage :: FromJSVal b => MonadJSM m => ParDiffT a m b stage = liftJSM $ fromJSValUnchecked =<< jsg "container"