Bug in `Adjustable` implementation: internal networks of elements end up broken/disconnected

[johannesgerer]

Using the functionality provided by the Adjustable type class seems crucial for any non-trivial app. Yet, there seems to be an issue, which I was not able to fix and I would appreciate any help.

I have put together the script below which demonstrates the problem.

What the script does

It will render a list with two elements, each showing the current value of a running counter.

There a two buttons, A, which swaps the two elements and B which rerenders the first element.

How to reproduce the bug

Pressing button A then button B, will make the second element stop showing updates to the counter value.

Pressing button B then button A, will make both elements stop showing updates.

The same happens for any use of runWithReplace, dyn, widgetHold and the like within the elements.

The code

import qualified Data.Map as M
import qualified Data.Text as T
import           Prelude
import           Data.Maybe
import           Language.Javascript.JSaddle.Warp (run)
import           Reflex.Dom hiding (mainWidget, run, mainWidgetWithHead, Error)
import           Reflex.Dom.Core (mainWidget)
import           Reflex.Patch.MapWithMove


pshow :: Show a => a -> T.Text
pshow = T.pack . show
  
main :: IO ()
main = run 8000 $
  mainWidget mainW


mainW :: forall t m . MonadWidget t m => m ()
mainW = do
  text "counter: "

  hb <- holdDyn 0  . fmap _tickInfo_n =<<tickLossyFromPostBuildTime 0.1
  dynText $ pshow <$> hb

  let swap = fromMaybe (error "invalid patch") $ patchMapWithMove 
        ( M.fromList [( 0 , NodeInfo 
                        { _nodeInfo_from = From_Move 1
                        , _nodeInfo_to = Just 1
                        }) , 
                      ( 1 , NodeInfo 
                        { _nodeInfo_from = From_Move 0
                        , _nodeInfo_to = Just 0
                        })])
      break = fromMaybe (error "invalid patch") $ patchMapWithMove 
        ( M.fromList [( 0 , NodeInfo 
                            { _nodeInfo_from = From_Insert 'z'
                            , _nodeInfo_to = Nothing
                            })])
  patchE <- el "p" $ do
    b1 <- button "A: swap"
    b2 <- button "B: update 0th element"
    return $ leftmost [swap <$ b1, break <$ b2]


  let render k v = do
        el "h5" $ text $ pshow (k,v)
        dyn $ el "p" . text . pshow <$> hb

  mapMapWithAdjustWithMove render (M.fromList $ zip [0..] "ab") patchE
    
  return ()

[JBetz]

Relocated because I was able to reproduce this using only reflex:

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Concurrent (newChan, readChan)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Reader (void)
import Control.Monad (forM, forM_)
import Control.Monad.Fix (fix, MonadFix)
import Control.Monad.Identity (Identity(..))
import Data.Dependent.Sum (DSum ((:=>)))
import Data.IORef (readIORef)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as Map

import Reflex
import Reflex.Network
import Reflex.Patch.MapWithMove
import Reflex.Host.Class

main :: IO ()
main =
  host guest

type App t m =
  ( Reflex t
  , MonadHold t m
  , MonadFix m
  , MonadIO m
  , NotReady t m
  , Adjustable t m
  , MonadIO (Performable m)
  , PostBuild t m
  , PerformEvent t m
  , TriggerEvent t m
  ) => m (Behavior t Text)

host :: (forall t m. App t m) -> IO ()
host myGuest = runSpiderHost $ do
  (postBuildE, postBuildTriggerRef) <- newEventWithTriggerRef
  events <- liftIO newChan

  (textB, FireCommand fire) <-
    hostPerformEventT $
      flip runPostBuildT postBuildE $
        flip runTriggerEventT events $
          myGuest

  let update = sample textB >>= liftIO . putStrLn . T.unpack

  mPostBuildTrigger <- liftIO $ readIORef postBuildTriggerRef
  forM_ mPostBuildTrigger $ \postBuildTrigger ->
    fire [postBuildTrigger :=> Identity ()] $ return ()

  update

  void $ fix $ \loop -> do
    ers <- liftIO $ readChan events
    void $ fireEventTriggerRefs fire ers
    update
    loop

  where
    fireEventTriggerRefs
      :: (Monad (ReadPhase m), MonadIO m)
      => ([DSum (EventTrigger t) Identity] -> ReadPhase m Bool -> m [a])
      -> [DSum (EventTriggerRef t) TriggerInvocation]
      -> m ()
    fireEventTriggerRefs fire ers = do
      mes <- liftIO $
        forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
          me <- readIORef er
          return $ fmap (\e -> e :=> Identity a) me
      _ <- fire (catMaybes mes) $ return False
      liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb


guest :: forall t m. App t m
guest = do
  (_, textB) <- runBehaviorWriterT $ mdo
    ticker <- holdDyn 0  . fmap _tickInfo_n =<< tickLossyFromPostBuildTime 0.4
    _ <- mapMapWithAdjustWithMove
      (\k v -> networkView ((\t -> display (k, v, t)) <$> ticker))
      (Map.fromList $ zip [0..] "ab")
      patchE
    (patchE, patchCB) <- newTriggerEvent
    liftIO $ do
      patchCB swap
      patchCB update0th
  return textB

  where
    swap, update0th :: PatchMapWithMove Int Char
    swap = fromJust $ patchMapWithMove $ Map.fromList
      [ (0, NodeInfo (From_Move 1) (Just 1))
      , (1, NodeInfo (From_Move 0) (Just 0))
      ]
    update0th = fromJust $ patchMapWithMove $ Map.fromList
      [ (0, NodeInfo (From_Insert 'z') Nothing) ]

    display a = tellBehavior $ constant $ T.pack $ show a <> "  "

[JBetz]

@johannesgerer Thanks for helping us track this down! We've got something that should fix it on the way.