MoveScope

Clickable/DOM.hs

@@ -32,7 +32,7 @@ defaultListenerOptions = ListenerOptions {
 }
 
 addEventListener :: FromJSVal a => (Event a -> JSExp) -> (a -> JSM ()) -> JSM ()
-addEventListener addScript k =
+addEventListener script k =
   reactive add >>= jsCmd where
     add scope s = (s''', cmd) where
       k' = localScope scope . k
@@ -41,7 +41,7 @@ addEventListener addScript k =
       s'' = subscribeEventFn (unsafeFromEventId eventId)
         (mapM_ k' . fromJSVal . unsafeCoerce) scope s'
       s''' = installFinalizerFn (jsCmd $ Apply (Ref unsub) []) scope s''
-      cmd = AssignRef unsub $ addScript $ Event eventId
+      cmd = AssignRef scope unsub $ script $ Event eventId
 
 class EventName eventName where
   type EventListenerCb eventName :: Type

Clickable/HTML.hs

@@ -2,18 +2,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
 {-# OPTIONS_GHC -Wall #-}
 module Clickable.HTML where
 
 import Clickable.Internal
 import Clickable.Types
-import Control.Monad
 import Control.Monad.Trans
 import Data.IORef
 import Data.Text (Text)
@@ -46,7 +40,7 @@ dynText contentDyn = HTML \s e -> do
   c <- readDyn contentDyn
   refId <- newRefId.unJSM e
   e.ien_command $ PushStack $ CreateText c
-  e.ien_command $ AssignRef refId (PeekStack 0)
+  e.ien_command $ AssignRef e.ien_scope refId (PeekStack 0)
   e.ien_command PopIns
   let k nval = JSM \e' ->
         e'.ien_command $ UpdateText (Ref refId) nval
@@ -116,7 +110,7 @@ saveStackHead = HTML \s e ->
   case s of
     Nothing -> do
       refId <- newRefId.unJSM e
-      e.ien_command $ AssignRef refId $ PeekStack 0
+      e.ien_command $ AssignRef e.ien_scope refId $ PeekStack 0
       return (refId, Just refId)
     Just saved ->
       pure (saved, s)
@@ -127,94 +121,88 @@ blank = pure ()
 
 dyn :: Dynamic (HTML ()) -> HTML ()
 dyn val = do
-  brackets <- liftJSM insertBrackets
   scope <- liftJSM newScope
-  initialVal <- liftJSM $ readDyn val
-  let
-    update html = do
-      liftJSM $ clearBrackets brackets
-      html
-    exec h =
-      localScope scope $ customize (Ref brackets) h
-  liftJSM $ exec $ update initialVal
+  place <- liftJSM insertPlaceholder
+  initial <- liftJSM $ readDyn val
+  liftJSM $ update scope place initial
   liftJSM $ subscribe val \newVal -> do
     freeScope scope
-    exec $ update newVal
+    update scope place newVal
+  where
+    update scope place content =
+      localScope scope do
+        clearPlaceholder place
+        execHTML (Ref place) content
 
 -- | Auxilliary datatype used in 'simpleList' implementation
-data ElemEnv a = ElemEnv {
-  brackets :: RefId,
-  state_var :: DynVar a,
+data InternalElem a = InternalElem {
+  placeholder :: RefId,
+  elem_state :: DynVar a,
   elem_scope :: ScopeId
 }
 
 -- | Display dynamic collection of widgets. NOTE: changes in `DynVar
 -- a` do not automatically propagate into the larger state. See
 -- `OverrideVar` and todomvc example to see one way to upstream
 -- changes into the larger state.
-simpleList ::
-  forall a. Dynamic [a] ->
-  (Int -> DynVar a -> HTML ()) ->
+simpleList :: forall a.
+  Dynamic [a] ->
+  (DynVar a -> HTML ()) ->
   HTML ()
-simpleList listDyn h = liftJSM do
-  internalStateRef <- liftIO $ newIORef ([] :: [ElemEnv a])
-  brackets <- insertBrackets
-  let
-    exec brackets' scope =
-      localScope scope . customize (Ref brackets')
-    exec1 brackets' = customize (Ref brackets')
-
-    setup :: Int -> [a] -> [ElemEnv a] -> JSM [ElemEnv a]
-    setup idx new existing = case (existing, new) of
-      ([], []) -> return []
+simpleList listDyn h = do
+  ref <- liftIO $ newIORef ([] :: [InternalElem a])
+  place <- liftJSM insertPlaceholder
+  initial <- readDyn listDyn
+  liftJSM $ execHTML (Ref place) $ liftJSM $ updateList ref initial
+  liftJSM $ subscribe listDyn $ execHTML (Ref place) . liftJSM . updateList ref
+  where
+    synchronize :: [a] -> [InternalElem a] -> JSM [InternalElem a]
+    synchronize [] [] = return []
+    synchronize (x:xs) [] = do
       -- New list is longer, append new elements
-      ([], x:xs) -> do
-        e <- newElem x
-        exec e.brackets e.elem_scope $ h idx e.state_var
-        fmap (e:) $ setup (idx + 1) xs []
+      e <- newElem x
+      localScope e.elem_scope $ execHTML (Ref e.placeholder) $ h e.elem_state
+      fmap (e:) $ synchronize xs []
+    synchronize [] (r:rs) = do
       -- New list is shorter, delete the elements that no longer
       -- present in the new list
-      (r:rs, []) -> do
-        finalizeElems True (r:rs)
-        return []
+      mapM_ dropElem (r:rs)
+      pure []
+    synchronize (y:ys) (r:rs) = do
       -- Update existing elements along the way
-      (r:rs, y:ys) -> do
-        writeVar r.state_var y
-        fmap (r:) $ setup (idx + 1) ys rs
-    newElem :: a -> JSM (ElemEnv a)
+      writeVar r.elem_state y
+      fmap (r:) $ synchronize ys rs
+    newElem :: a -> JSM (InternalElem a)
     newElem a = do
-      elem_scope <- newScope
-      localScope elem_scope do
-        state_var <- newVar a
-        brackets' <- insertBrackets
-        return ElemEnv {elem_scope, state_var, brackets = brackets'}
-    finalizeElems :: Bool -> [ElemEnv a] -> JSM ()
-    finalizeElems remove = mapM_ \ee -> do
-      when remove $ detachBrackets ee.brackets
+      scope <- newScope
+      localScope scope do
+        elem_state <- newVar a
+        place' <- insertPlaceholder
+        pure InternalElem {elem_scope = scope, elem_state, placeholder = place'}
+    dropElem :: InternalElem a -> JSM ()
+    dropElem ee = do
       destroyScope ee.elem_scope
-    updateList :: [a] -> JSM ()
-    updateList new = do
-      eenvs <- liftIO $ readIORef internalStateRef
-      newEenvs <- setup 0 new eenvs
-      liftIO $ writeIORef internalStateRef newEenvs
-  initialVal <- readDyn listDyn
-  exec1 brackets $ liftJSM $ updateList initialVal
-  subscribe listDyn $ exec1 brackets . liftJSM . updateList
-
-insertBrackets :: JSM RefId
-insertBrackets = do
-  brackets <- newRefId
-  jsCmd $ AssignRef brackets InsertBrackets
-  pure brackets
-
-clearBrackets :: RefId -> JSM ()
-clearBrackets rid = jsCmd $ ClearBrackets $ Ref rid
-
-detachBrackets :: RefId -> JSM ()
-detachBrackets rid = jsCmd $ DetachBrackets $ Ref rid
-
-customize :: JSExp -> HTML a -> JSM a
-customize elm action = JSM \e -> do
+      detachPlaceholder ee.placeholder
+    updateList :: IORef [InternalElem a] -> [a] -> JSM ()
+    updateList ref new = do
+      ees <- liftIO $ readIORef ref
+      ees' <- synchronize new ees
+      liftIO $ writeIORef ref ees'
+
+insertPlaceholder :: JSM RefId
+insertPlaceholder = JSM \e -> do
+  ref <- newRefId.unJSM e
+  e.ien_command $ AssignRef e.ien_scope ref InsertPlaceholder
+  pure ref
+
+clearPlaceholder :: RefId -> JSM ()
+clearPlaceholder rid = jsCmd $ ClearPlaceholder $ Ref rid
+
+detachPlaceholder :: RefId -> JSM ()
+detachPlaceholder rid = jsCmd $ DetachPlaceholder $ Ref rid
+
+execHTML :: JSExp -> HTML a -> JSM a
+execHTML elm action = JSM \e -> do
   e.ien_command $ PushStack elm
   (r, _) <- action.unHTML Nothing e
   e.ien_command PopStack

Clickable/Internal.hs

@@ -196,48 +196,65 @@ newRefId = reactive newRefIdFn
 {-# INLINE newRefId #-}
 
 newRefIdFn :: ScopeId -> InternalState -> (InternalState, RefId)
-newRefIdFn e s = (s {ist_id_supply = s.ist_id_supply + 1}, RefId e s.ist_id_supply)
+newRefIdFn _e s = (s {ist_id_supply = s.ist_id_supply + 1}, RefId s.ist_id_supply)
 {-# INLINE newRefIdFn #-}
 
 freeScope :: ScopeId -> JSM ()
-freeScope s = do
-  mres <- state $ swap . freeScopeFn s
-  forM_ mres \r -> forM_ r.rsr_linked destroyScope
-  forM_ mres \r -> sequence_ r.rsr_finalizers
-{-# INLINE freeScope #-}
-
-freeScopeFn :: ScopeId -> InternalState -> (InternalState, Maybe Resources)
-freeScopeFn scope s = (s', resources)
+freeScope scope = do
+  mres <- state updateState
+  forM_ mres \res -> do
+    forM_ (res.rsr_linked) destroyScope
+    sequence_ (res.rsr_finalizers)
+  jsCmd $ FreeScope scope
   where
-    subs = Map.map (List.filter filterSub) s.ist_subscriptions
-    filterSub sub = sub.sub_scope /= scope
-    (resources, rsr) = Map.alterF (,Nothing) scope s.ist_resources
-    s' = s {ist_subscriptions = subs, ist_resources = rsr}
-{-# INLINE freeScopeFn #-}
+    updateState :: InternalState -> (Maybe Resources, InternalState)
+    updateState s = (res, s')
+      where
+        subs = Map.map (filter (not . isTargetScope)) s.ist_subscriptions
+        isTargetScope sub = sub.sub_scope == scope
+        (res, rsr) = Map.alterF (, Nothing) scope s.ist_resources
+        s' = s {ist_subscriptions = subs, ist_resources = rsr}
 
 destroyScope :: ScopeId -> JSM ()
-destroyScope s = do
-  mres <- state $ swap . destroyScopeFn s
-  forM_ mres \r -> forM_ r.rsr_linked destroyScope
-  forM_ mres \r -> sequence_ r.rsr_finalizers
-{-# INLINE destroyScope #-}
-
-destroyScopeFn :: ScopeId -> InternalState -> (InternalState, Maybe Resources)
-destroyScopeFn scope s = (s', resources)
+destroyScope scope = do
+  mres <- state updateState
+  forM_ mres \res -> do
+    forM_ (res.rsr_linked) destroyScope
+    sequence_ (res.rsr_finalizers)
+  jsCmd $ FreeScope scope
   where
-    subs = Map.map (List.filter filterSub) s.ist_subscriptions
-    filterSub x = x.sub_scope /= scope
-    remove = Map.alterF (,Nothing) scope
-    unlink m = case resources of
-      Just r -> Map.adjust adj r.rsr_parent m
-      Nothing -> m
-    adj r = r {rsr_linked = List.filter (/=scope) r.rsr_linked}
-    (resources, rsr) = remove s.ist_resources
-    s' = s {ist_subscriptions = subs, ist_resources = unlink rsr}
-{-# INLINE destroyScopeFn #-}
+    updateState :: InternalState -> (Maybe Resources, InternalState)
+    updateState s = (res, s')
+      where
+        subs = Map.map (filter (not . isTargetScope)) s.ist_subscriptions
+        isTargetScope sub = sub.sub_scope == scope
+        remove = Map.alterF (,Nothing) scope
+        unlink m = case res of
+          Just r -> Map.adjust adj r.rsr_parent m
+          Nothing -> m
+        adj r = r {rsr_linked = List.filter (/=scope) r.rsr_linked}
+        (res, rsr) = remove s.ist_resources
+        s' = s {ist_subscriptions = subs, ist_resources = unlink rsr}
+
+moveScope :: ScopeId -> ScopeId -> JSM ()
+moveScope src dest = do
+  modify updateState
+  jsCmd $ MoveScope src dest
+  where
+    updateState :: InternalState -> InternalState
+    updateState s
+      | Just srcRes <- Map.lookup src s.ist_resources =
+          s {ist_resources = Map.adjust (updateRes srcRes) dest s.ist_resources}
+      | otherwise = s
+      where
+        updateRes :: Resources -> Resources -> Resources
+        updateRes src' dest' = dest' {
+          rsr_linked = src'.rsr_linked <> dest'.rsr_linked,
+          rsr_finalizers = src'.rsr_finalizers <> dest'.rsr_finalizers
+        }
 
 installFinalizer :: JSM () -> JSM ()
-installFinalizer = reactive_ . installFinalizerFn
+installFinalizer f = reactive_ $ installFinalizerFn f
 {-# INLINE installFinalizer #-}
 
 installFinalizerFn :: JSM () -> ScopeId -> InternalState -> InternalState

Clickable/Types.hs

@@ -127,10 +127,10 @@ data JSExp where
   Apply :: JSExp -> [JSExp] -> JSExp
   Call :: JSExp -> Text -> [JSExp] -> JSExp
 
-  AssignRef :: RefId -> JSExp -> JSExp
-  FreeRef :: RefId -> JSExp
+  AssignRef :: ScopeId -> RefId -> JSExp -> JSExp
   Ref :: RefId -> JSExp
   FreeScope :: ScopeId -> JSExp
+  MoveScope :: ScopeId -> ScopeId -> JSExp
 
   PeekStack :: Word8 -> JSExp
   PushStack :: JSExp -> JSExp
@@ -141,9 +141,9 @@ data JSExp where
   ElementAttr :: JSExp -> Text -> Text -> JSExp
   ClassListAdd :: JSExp -> Text -> JSExp
   ClassListRemove :: JSExp -> Text -> JSExp
-  InsertBrackets :: JSExp
-  ClearBrackets :: JSExp -> JSExp
-  DetachBrackets :: JSExp -> JSExp
+  InsertPlaceholder :: JSExp
+  ClearPlaceholder :: JSExp -> JSExp
+  DetachPlaceholder :: JSExp -> JSExp
 
   CreateElement :: Text -> JSExp
   CreateElementNS :: Text -> Text -> JSExp
@@ -175,9 +175,8 @@ newtype StartFlags = StartFlags {unStartFlags :: JSVal}
 newtype ScopeId = ScopeId {unScopeId :: Word32}
   deriving newtype (Binary, Eq, Ord, Show)
 
-data RefId = RefId ScopeId Word32
-  deriving stock (Eq, Show, Generic)
-  deriving anyclass (Binary)
+newtype RefId = RefId {unRefId :: Word32}
+  deriving newtype (Binary, Eq, Ord, Show)
 
 newtype EventId = EventId {unEventId :: Word32}
   deriving newtype (Show, Ord, Eq, Binary)
@@ -520,13 +519,15 @@ prompt (PromptTag t) (IO m) = IO (prompt# t m)
 control :: forall a b. PromptTag a -> ((IO b -> IO a) -> IO a) -> IO b
 control (PromptTag t) f = IO (control0# t g)
   where
-    g :: ((State# RealWorld -> (# State# RealWorld, b #))
-      -> State# RealWorld -> (# State# RealWorld, a #))
-      -> State# RealWorld -> (# State# RealWorld, a #)
+    g ::
+      ((State# RealWorld -> (# State# RealWorld, b #)) ->
+        State# RealWorld -> (# State# RealWorld, a #)) ->
+      State# RealWorld -> (# State# RealWorld, a #)
     g h = let IO m = f (k h) in m
-    k :: ((State# RealWorld -> (# State# RealWorld, b #))
-      -> State# RealWorld -> (# State# RealWorld, a #))
-      -> IO b -> IO a
+    k ::
+      ((State# RealWorld -> (# State# RealWorld, b #)) ->
+        State# RealWorld -> (# State# RealWorld, a #)) ->
+      IO b -> IO a
     k l (IO n) = IO (l n)
 
 data PromptTag a = PromptTag {unPromptTag :: PromptTag# a}