implement portal

deku-core/src/Deku/Core.purs

@@ -69,6 +69,7 @@ module Deku.Core
   , useState
   , useState'
   , useStateTagged'
+  , portal
   , withUnsub
   , xdata
   ) where
@@ -79,18 +80,20 @@ import Control.Alt ((<|>))
 import Control.Monad.ST.Class (liftST)
 import Control.Monad.ST.Global (Global)
 import Control.Monad.ST.Internal as ST
-import Control.Monad.ST.Uncurried (runSTFn1)
+import Control.Monad.ST.Uncurried (mkSTFn1, runSTFn1, runSTFn2)
 import Control.Plus (empty)
 import Data.Array as Array
 import Data.Array.ST as STArray
 import Data.Compactable (compact)
-import Data.Maybe (Maybe(..))
+import Data.Foldable (traverse_)
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (class Newtype, over, un)
+import Data.Traversable (sequence)
 import Data.Tuple (Tuple(..))
 import Data.Tuple.Nested (type (/\), (/\))
 import Deku.Do as Deku
 import Deku.Internal.Entities (DekuChild(..), DekuElement, DekuParent(..), DekuText, fromDekuElement, toDekuElement)
-import Deku.Internal.Region (Anchor(..), Region(..), RegionSpan(..), StaticRegion(..), fromParent)
+import Deku.Internal.Region (Anchor(..), Bound, Region(..), RegionSpan(..), StaticRegion(..), fromParent, newStaticRegion)
 import Effect (Effect)
 import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn2, runEffectFn3)
 import FRP.Event as Event
@@ -476,6 +479,7 @@ useDynWith elements options cont = Nut $ mkEffectFn2 \psr di -> do
     handleElements :: EffectFn1 ( Tuple ( Maybe Int ) value ) Unit
     handleElements = mkEffectFn1 \( Tuple initialPos value ) -> do
       Region eltRegion <- liftST $ runSTFn1 span initialPos
+      region <- liftST $ runSTFn2 newStaticRegion eltRegion.begin eltRegion.bump
       eltSendTo <- liftST Poll.create
       let
         sendTo :: Poll Int
@@ -499,11 +503,7 @@ useDynWith elements options cont = Nut $ mkEffectFn2 \psr di -> do
 
         eltPSR :: PSR
         eltPSR =
-          PSR
-            { region : eltRegion.static
-            , unsubs : []
-            , lifecycle : remove
-            }
+          PSR { region, unsubs : [], lifecycle : remove }
 
         handleManagedLifecycle :: EffectFn1 Unit Unit
         handleManagedLifecycle =
@@ -652,36 +652,79 @@ text texts = Nut $ mkEffectFn2 \psr di -> do
 
   pump unsubs ( un PSR psr ).lifecycle handleLifecycle
 
--- portal :: Nut -> Hook Nut
--- portal (Nut toBeam) f = Nut $ mkEffectFn2
---   \psr
---    di@(DOMInterpret { makeElement }) ->
---     do
---       frag <- runEffectFn2 makeElement Nothing (Tag "div")
---       beamMe <- runEffectFn2 toBeam
---         ( PSR
---             { parent: frag
---             , fromPortal: true
---             , unsubs: []
---             , beacon: Nothing
---             }
---         )
---         di
---       let giveNewParent = Nut $ oh'hi beamMe
---       let Nut nut = f giveNewParent
---       runEffectFn2 nut psr di
---   where
---   oh'hi beamMe = mkEffectFn2
---     \ps
---      di -> do
---       case beamMe of
---         -- if the outcome is an element, just move it
---         DekuElementOutcome elt -> runEffectFn3 eltAttribution ps di elt
---         -- if the outcome is a text, just move it
---         DekuTextOutcome txt -> runEffectFn3 textAttribution ps di txt
---         --beacon
---         DekuBeaconOutcome stBeacon -> do
---           -- if the outcome is a beacon and the beacon's parent is an element, we're in for a slog, itearte over the whole thing
---           runEffectFn3 beaconAttribution ps di stBeacon
---         NoOutcome -> pure unit
---       pure beamMe
+-- | Creates a `Nut` that can be attached to another part of the application. The lifetime of the `Nut` is no longer
+-- | than that of `Nut` that created it.
+-- maybe also attach the lifetime to its mountpoints and/or do reference counting
+portal :: Nut -> Hook Nut
+portal ( Nut toBeam ) cont = Nut $ mkEffectFn2 \psr di -> do
+
+  -- set up a StaticRegion for the portal contents and track its begin and end
+  buffer <- ( un DOMInterpret di ).bufferPortal
+  trackBegin <- liftST $ ST.new $ pure @( ST.ST Global ) $ ParentStart buffer
+  trackEnd <- liftST $ ST.new $ Nothing @Bound
+
+  -- signal for other locations of the portal that it's contents have moved
+  beamed <- liftST Event.create
+  bumped <- liftST Event.createPure
+
+  staticBuffer <- liftST $ runSTFn2 newStaticRegion
+    ( join $ ST.read trackBegin )
+    ( mkSTFn1 \bound -> do
+      void $ ST.write bound trackEnd
+      bumped.push bound
+    )
+  runEffectFn2 toBeam ( over PSR _ { region = staticBuffer } psr ) di
+
+  let
+    Nut hooked = cont $ portaled ( beamed.push unit ) beamed.event bumped.event trackBegin trackEnd
+
+  runEffectFn2 hooked psr di
+
+portaled :: Effect Unit
+  -> Event.Event Unit 
+  -> Event.Event ( Maybe Bound )
+  -> ST.STRef Global Bound
+  -> ST.STRef Global ( Maybe Bound )
+  -> Nut
+portaled beam beamed bumped trackBegin trackEnd = Nut $ mkEffectFn2 \psr di -> do  
+  -- signal to other portaled `Nut`s that we are about to steal their content
+  beam
+
+  -- set up region and its eventual cleanup
+  Region region <- liftST ( un StaticRegion ( un PSR psr ).region ).region
+  stolen <- liftST $ ST.new false
+  let 
+    -- when someone else beams from the portal or the `Nut` gets removed we clean up the region
+    cleanRegion :: Effect Unit
+    cleanRegion =
+      whenM ( not <$> liftST ( ST.read stolen ) ) do
+        void $ liftST $ ST.write true stolen
+        liftST region.remove
+
+  unsubBeamed <- runEffectFn2 Event.subscribeO beamed $ mkEffectFn1 \_ -> cleanRegion
+  unsubBumped <- runEffectFn2 Event.subscribeO bumped $ mkEffectFn1 $ liftST <<< runSTFn1 region.bump
+
+  -- region starts empty, only bump when we actually have an end
+  liftST $ ST.read trackEnd >>= traverse_ ( runSTFn1 region.bump <<< Just )
+
+  -- actuall insert portal contents
+  begin <- liftST $ join $ ST.read trackBegin
+  end <- liftST $ sequence =<< ST.read trackEnd
+  target <- liftST region.begin
+  runEffectFn3 ( un DOMInterpret di ).beamRegion begin ( fromMaybe begin end ) target
+
+  -- update the tracked begin so other portaled `Nut`s can steal the contents correctly
+  void $ liftST $ ST.write region.begin trackBegin
+
+  -- lifecycle handling
+  unsubs <- runEffectFn1 collectUnsubs psr
+  void $ liftST $ STArray.push unsubBeamed unsubs
+  void $ liftST $ STArray.push unsubBumped unsubs
+
+  let
+    handleLifecycle :: EffectFn1 Unit Unit
+    handleLifecycle = mkEffectFn1 \_ -> do
+      runEffectFn1 disposeUnsubs unsubs
+      cleanRegion
+
+  pump unsubs ( un PSR psr ).lifecycle handleLifecycle

deku-core/src/Deku/Internal/Region.purs

@@ -1,11 +1,11 @@
 -- | `Region`s are used to figure out the bounds of collections of managed elements. The difficulty lies mostly in empty
 -- | managed regions, they have nothing to get a hold of and need to be managed outside of the DOM. To communicate the
--- | presence or absence of elements, `Region`s have to use `Bump` to signal to their parents that they contain an
--- | element that can be used to locate a region or `Clear` to signal that no elements to locate.
+-- | presence or absence of elements, `Region`s have to use `Bump Just` to signal to their parents that they contain an
+-- | element that can be used to locate a region or `Bump Nothing` to signal that it contains no elements to locate.
 -- |
 -- | It is then the responsibilty of the parent to use the information of all its children to provide correct `Bound`
--- | information to i.e. `DOMInterpret` to use `attachElement` or `beamRegion`. A `Bump` causes all following `Region`s
--- | to update their begin(and their end when empty) until a new non-empty region is found. A `Clear` causes the
+-- | information to i.e. `DOMInterpret` to use `attachElement` or `beamRegion`. A `Bump Just` causes all following `Region`s
+-- | to update their begin(and their end when empty) until a new non-empty region is found. A `Bump Nothing` causes the
 -- | inverse. First a non-empty `Region` has be found which will be used to update the beginning of all following empty
 -- | `Region`s until a new non-empty `Region` is found.
 module Deku.Internal.Region
@@ -14,7 +14,9 @@ module Deku.Internal.Region
     , Region(..)
     , StaticRegion(..)
     , RegionSpan(..)
+    , Bump
     , fromParent
+    , newStaticRegion
     ) where
 
 import Prelude
@@ -28,7 +30,7 @@ import Data.Array as Array
 import Data.Array.ST as STArray
 import Data.Foldable (traverse_)
 import Data.Maybe (Maybe(..), fromJust, fromMaybe)
-import Data.Newtype (class Newtype, un)
+import Data.Newtype (class Newtype)
 import Deku.Internal.Entities (DekuElement, DekuParent, DekuText)
 import FRP.Event (createPure)
 import FRP.Poll (Poll, pollFromEvent, stRefToPoll)
@@ -43,10 +45,7 @@ type Bound =
     ST.ST Global Anchor
 
 type Bump =
-    STFn1 Bound Global Unit
-
-type Clear =
-    ST.ST Global Unit
+    STFn1 ( Maybe Bound ) Global Unit
 
 -- | Region that supports adding, moving and removing new child regions.
 newtype Region = Region
@@ -57,14 +56,15 @@ newtype Region = Region
     , sendTo :: STFn1 Int Global Unit
     , remove :: ST.ST Global Unit
 
-    , static :: StaticRegion
+    , bump :: Bump
     }
 derive instance Newtype Region _
 
 -- | Region that supports adding new regions and elements.
 newtype StaticRegion = StaticRegion
     { end :: Bound
     , span :: ST.ST Global RegionSpan
+    , region :: ST.ST Global Region
     , element :: STFn1 Anchor Global Unit
     }
 derive instance Newtype StaticRegion _
@@ -97,8 +97,8 @@ newtype RegionSpan =
     RegionSpan ( STFn1 ( Maybe Int ) Global Region )
 derive instance Newtype RegionSpan _
 
-newSpan :: STFn3 Bound Bump Clear Global RegionSpan
-newSpan = mkSTFn3 \parent parentBump parentClear -> do
+newSpan :: STFn2 Bound Bump Global RegionSpan
+newSpan = mkSTFn2 \parent parentBump -> do
     children <- STArray.new
     -- bound owned by an element outside of this region
 
@@ -130,15 +130,15 @@ newSpan = mkSTFn3 \parent parentBump parentClear -> do
                 runSTFn1 readSharedBound managed.end
 
             bump :: Bump
-            bump = mkSTFn1 \bound -> do
-                runSTFn3 bumpBound bound managed children
-                whenM ( runSTFn2 isLastBound managed children ) ( runSTFn1 parentBump bound )
+            bump = mkSTFn1 case _ of
+                Nothing -> do
+                    runSTFn2 clearBound managed children
+                    whenM ( runSTFn1 isClear children ) do
+                        runSTFn1 parentBump Nothing
 
-            clear :: Clear
-            clear = do
-                runSTFn2 clearBound managed children
-                whenM ( runSTFn1 isClear children ) do
-                    parentClear
+                b@( Just bound ) -> do
+                    runSTFn3 bumpBound bound managed children
+                    whenM ( runSTFn2 isLastBound managed children ) ( runSTFn1 parentBump b )
 
             sendTo :: STFn1 Int Global Unit
             sendTo = mkSTFn1 \pos -> do
@@ -173,23 +173,22 @@ newSpan = mkSTFn3 \parent parentBump parentClear -> do
 
             remove :: ST.ST Global Unit
             remove = do
-                clear
+                runSTFn1 bump Nothing
                 finalIx <- ix
                 void $ STArray.splice finalIx ( finalIx + 1 ) [] children
                 runSTFn3 fixManaged finalIx updateIx children
 
-        static <- runSTFn3 newStaticRegion begin bump clear
-        pure $ Region { begin, end, position, sendTo, remove, static }
+        pure $ Region { begin, end, position, sendTo, remove, bump }
 
 -- | Determines the final `Bound` and runs the provided effect on it.
 -- | ASSUMES that the last element is not the parent.
-rebumpLast :: STFn2 ( STFn1 Bound Global Unit ) ( STArray.STArray Global ManagedRegion ) Global Unit
+rebumpLast :: STFn2 Bump ( STArray.STArray Global ManagedRegion ) Global Unit
 rebumpLast = mkSTFn2 \bump children -> do
     length <- STArray.length children
     STArray.peek ( length - 1 ) children >>= traverse_ \lastRegion -> do
         end <- ST.read lastRegion.end
         bound <- ST.read end.ref
-        runSTFn1 bump bound
+        runSTFn1 bump $ Just bound
 
 -- | Uses the bound information to infer if the whole span is empty.
 isClear :: STFn1 ( STArray.STArray Global ManagedRegion ) Global Boolean
@@ -383,44 +382,56 @@ isSpanning = case _ of
     Spanning _ -> true
     _ -> false
 
-newStaticRegion :: STFn3 Bound Bump Clear Global StaticRegion
-newStaticRegion = mkSTFn3 \parent bump clear -> do
+newStaticRegion :: STFn2 Bound Bump Global StaticRegion
+newStaticRegion = mkSTFn2 \parent bump -> do
     spanCounter <- ST.new (-1) -- making the first span 0
     -- when any static element is added it can not be removed by this static region so this anchor can be used to bump 
     -- when the last child span signals a clear
     state <- ST.new $ Anchored parent
 
     end <- ST.new parent
+    let
+        findOrCreateSpan :: ST.ST Global RegionSpan
+        findOrCreateSpan = ST.read state >>= case _ of
+            Anchored begin -> do
+                spanIx <- ST.modify ( add 1 ) spanCounter
+                span <- runSTFn2 newSpan
+                    ( begin )
+                    ( mkSTFn1 case _ of
+                        Nothing ->
+                            whenM ( eq spanIx <$> ST.read spanCounter ) do
+                                void $ ST.write begin end
+                                -- only signal clear when we are the first and only span
+                                when ( spanIx == 0 ) $ runSTFn1 bump Nothing
+
+                        a@( Just anchor ) ->
+                            whenM ( eq spanIx <$> ST.read spanCounter ) do
+                                void $ ST.write anchor end
+                                runSTFn1 bump a
+                    )
+
+                pure span
+
+            Spanning span ->
+                pure span
+
     pure $ StaticRegion
         { end : join $ ST.read end
         , span : do
             -- find or create a span
-            RegionSpan span <- ST.read state >>= case _ of
-                Anchored begin -> do
-                    spanIx <- ST.modify ( add 1 ) spanCounter
-                    span <- runSTFn3 newSpan
-                        ( begin )
-                        ( mkSTFn1 \a -> whenM ( eq spanIx <$> ST.read spanCounter ) do
-                            void $ ST.write a end
-                            runSTFn1 bump a
-                        )
-                        ( whenM ( eq spanIx <$> ST.read spanCounter ) do
-                            void $ ST.write begin end
-                            -- only signal clear when we are the first and only span
-                            when ( spanIx == 0 ) clear
-                        )
-
-                    pure span
-
-                Spanning span ->
-                    pure span
+            RegionSpan span <- findOrCreateSpan
 
             -- allocate a new region
             Region region <- runSTFn1 span Nothing
 
             -- create a single span in that region, this double allocation is necessary to isolate two spans in the same
             -- static region.
-            ( un StaticRegion region.static ).span
+            StaticRegion static <- runSTFn2 newStaticRegion region.begin region.bump
+            static.span
+
+        , region : do
+            RegionSpan span <- findOrCreateSpan
+            runSTFn1 span Nothing
 
         , element : mkSTFn1 \anchor' -> do
             let anchor = pure anchor'
@@ -431,9 +442,9 @@ newStaticRegion = mkSTFn3 \parent bump clear -> do
                 void $ ST.modify ( add 1 ) spanCounter
 
             void $ ST.write anchor end
-            runSTFn1 bump anchor
+            runSTFn1 bump $ Just anchor
         }
 
 fromParent :: STFn1 DekuParent Global StaticRegion
 fromParent = 
-    mkSTFn1 \parent -> runSTFn3 newStaticRegion ( pure $ ParentStart parent ) ( mkSTFn1 \_ -> pure unit ) mempty
+    mkSTFn1 \parent -> runSTFn2 newStaticRegion ( pure $ ParentStart parent ) ( mkSTFn1 \_ -> pure unit )