Add some weak action stuff

main.hs

@@ -19,6 +19,8 @@ import System.IO.Unsafe
 import Control.Monad
 import Control.Concurrent
 import Data.Foldable
+import Data.These
+import Unsafe.Coerce
 
 main :: IO ()
 main = do
@@ -28,6 +30,208 @@ main = do
   testGraphX
   testGraphO
 
+data WeakBagInput a
+data WeakBagOutput a
+data WeakMutVarInput a = WeakMutVarInput (WeakWithLifespan (IORef a))
+data WeakMutVarOutput a = WeakMutVarOutput (IORef a)
+
+data WeakWithLifespan a = WeakWithLifespan (Weak a) Lifespan
+
+newWeakMutVar :: a -> UIO (WeakMutVarInput a, WeakMutVarOutput a)
+newWeakMutVar a = do
+  r <- newIORef a
+  l <- lifespanOfIORef r
+  w <- newWeakWithLifespan l r
+  pure (WeakMutVarInput w, WeakMutVarOutput r)
+
+writeWeakMutVar :: WeakMutVarInput a -> UIO (Effect a)
+writeWeakMutVar target = mapEffect const =<< modifyWeakMutVar target
+
+modifyWeakMutVar :: WeakMutVarInput a -> UIO (Effect (a -> a))
+modifyWeakMutVar (WeakMutVarInput w) = Effect <$> do
+  mapWeakWithLifespan' (\r f -> atomicModifyIORef' r $ \v -> (f v, ())) w
+
+readWeakMutVar :: WeakMutVarOutput a -> Coeffect a
+readWeakMutVar (WeakMutVarOutput r) = Coeffect $ readIORef r
+
+testEffect1 :: IO ()
+testEffect1 = do
+  (i, o) <- newWeakMutVar "A"
+  e <- traceEffect id =<< writeWeakMutVar i
+  performGCUntilFinalizersQuiesce
+  putStrLn "X"
+  runEffect e "B"
+  touch o
+  _ <- runCoeffect (readWeakMutVar o)
+  performGCUntilFinalizersQuiesce
+  putStrLn "Y"
+  runEffect e "C"
+  putStrLn "Z"
+
+testEffect2 :: IO ()
+testEffect2 = do
+  (ia, oa) <- newWeakMutVar (1 :: Int)
+  (ib, ob) <- newWeakMutVar 1
+  modifyA <- traceEffect (const "modifyA") =<< modifyWeakMutVar ia
+  modifyB <- traceEffect (const "modifyB") =<< modifyWeakMutVar ib
+  let readA = readWeakMutVar oa
+  incrementA <- mapEffect (\() -> (+1)) modifyA
+  addToB <- mapEffect (\n -> (+n)) modifyB
+  addAToB <- withCoeffect readA addToB
+  e <- incrementA `andThen` addAToB
+  performGCUntilFinalizersQuiesce
+  runEffect e ((), ())
+  touch oa
+
+runEffect :: Effect a -> a -> IO ()
+runEffect (Effect e) a = deRefWeakWithLifespan e >>= \case
+  Nothing -> pure ()
+  Just f -> f a
+
+traceEffect :: (a -> String) -> Effect a -> UIO (Effect a)
+traceEffect f = weakEffect $ putStrLn . f
+
+-- Run the given IO action if the provided Effect is still runnable.  Note that the IO action may run even if the effect is *not* runnable, depending on garbage collection timing.
+weakEffect :: (a -> IO ()) -> Effect a -> UIO (Effect a)
+weakEffect f (Effect e) = fmap Effect $ forWeakWithLifespan' e $ \fe a -> do
+  f a
+  fe a
+
+runCoeffect :: Coeffect a -> IO a
+runCoeffect (Coeffect c) = c
+
+-- Unordered IO - we want to allocate things, strictly evaluate things, etc., but we don't actually care what order it is done in
+type UIO = IO
+
+emptyWeak :: Weak a
+emptyWeak = unsafeCoerce emptyWeakUnit
+
+{-# NOINLINE emptyWeakUnit #-}
+emptyWeakUnit :: Weak ()
+emptyWeakUnit = unsafePerformIO $ do
+  w <- mkWeakPtr () Nothing
+  finalize w
+  pure w
+
+newWeakWithLifespan :: Lifespan -> a -> UIO (WeakWithLifespan a)
+newWeakWithLifespan (Lifespan l) a = do
+  deRefWeak l >>= \case
+    Nothing -> pure $ WeakWithLifespan emptyWeak (Lifespan l)
+    Just r -> do
+      w <- mkWeakWithIORefKey r a
+      pure $ WeakWithLifespan w (Lifespan l)
+
+underlyingLifespan :: WeakWithLifespan a -> Lifespan
+underlyingLifespan (WeakWithLifespan _ l) = l
+
+deRefWeakWithLifespan :: WeakWithLifespan a -> UIO (Maybe a)
+deRefWeakWithLifespan (WeakWithLifespan w _) = deRefWeak w
+
+-- Applies the function strictly; usually this is what you want, so that extra data is not retained
+forWeakWithLifespan' :: WeakWithLifespan a -> (a -> b) -> UIO (WeakWithLifespan b)
+forWeakWithLifespan' = flip mapWeakWithLifespan'
+
+-- Applies the function strictly; usually this is what you want, so that extra data is not retained
+mapWeakWithLifespan' :: (a -> b) -> WeakWithLifespan a -> UIO (WeakWithLifespan b)
+mapWeakWithLifespan' f (WeakWithLifespan w l) = do
+  deRefWeak w >>= \case
+    Nothing -> pure $ WeakWithLifespan emptyWeak l
+    Just v -> newWeakWithLifespan l $! f v
+
+bothAlive :: WeakWithLifespan a -> WeakWithLifespan b -> UIO (WeakWithLifespan (a, b))
+bothAlive = undefined
+
+-- This is impossible because it assumes that weaks *do actual work* when you retrieve them.  This isn't what we want.
+alignAlive :: WeakWithLifespan a -> WeakWithLifespan b -> UIO (WeakWithLifespan (These a b))
+alignAlive = undefined
+
+data Effect a = Effect (WeakWithLifespan (a -> UIO ())) -- Take an `a` and do a side effect with it
+
+data Coeffect a = Coeffect (UIO a)  -- Read an `a` without doing any side effects
+
+-- Like `also`, but also guarantees order.  But I'm not sure what the semantics should really be here, since we could want coeffects ordered separately from effects
+andThen :: Effect a -> Effect b -> UIO (Effect (a, b))
+andThen = also
+
+also :: Effect a -> Effect b -> UIO (Effect (a, b))
+also (Effect ea) (Effect eb) = Effect <$> do
+  myLifespan <- unionLifespan (underlyingLifespan ea) (underlyingLifespan eb)
+  newWeakWithLifespan myLifespan $ \(a, b) -> do
+    deRefWeakWithLifespan ea >>= \case
+      Nothing -> pure ()
+      Just fa -> fa a
+    deRefWeakWithLifespan eb >>= \case
+      Nothing -> pure ()
+      Just fb -> fb b
+
+mapEffect :: (b -> a) -> Effect a -> UIO (Effect b)
+mapEffect f (Effect e) = Effect <$> mapWeakWithLifespan' (\fe -> fe . f) e
+
+withCoeffect :: Coeffect a -> Effect a -> UIO (Effect ())
+withCoeffect (Coeffect c) (Effect e) = Effect <$> do
+  let f fe () = do
+        v <- c
+        fe v
+  mapWeakWithLifespan' f e
+
+coAlso :: Coeffect a -> Coeffect b -> Coeffect (a, b)
+coAlso = undefined
+
+--TODO: This should use a WeakBag
+newtype Lifespan = Lifespan (Weak (IORef [LifespanBacklink]))
+newtype LifespanBacklink = LifespanBacklink (IORef [LifespanBacklink])
+
+modifyWeakIORef :: Weak (IORef a) -> (a -> a) -> IO ()
+modifyWeakIORef w f = deRefWeak w >>= \case
+  Nothing -> pure ()
+  Just r -> atomicModifyIORef' r $ \v -> (f v, ())
+
+lifespanOfIORef :: IORef a -> UIO Lifespan
+lifespanOfIORef basis = do
+  mine <- newIORef []
+  w <- mkWeakWithIORefKey basis mine -- This exploits the fact that System.Mem.Weak references keep the value alive even when the weak reference itself dies.
+  pure $ Lifespan w
+
+-- Return a lifespan
+unionLifespan :: Lifespan -> Lifespan -> UIO Lifespan
+unionLifespan (Lifespan a) (Lifespan b) = do
+  r <- newIORef []
+  w <- mkWeakWithIORefKey r r
+  modifyWeakIORef a (LifespanBacklink r :)
+  modifyWeakIORef b (LifespanBacklink r :)
+  pure $ Lifespan w
+
+intersectionLifespan :: Lifespan -> Lifespan -> UIO Lifespan
+intersectionLifespan a b = undefined
+
+-- If we do readWeakMutVar v `bind` writeWeakMutVar v', we should only keep v alive if `v'`'s output side is alive
+bind :: IO a -> (a -> IO b) -> IO b
+bind = undefined
+
+data Event a = Event
+  { _event_items :: WeakBagInput (a -> IO ()) -- Allows adding items to the weak bag.  Does not keep the weak bag alive; if the bag is gone, adding an item does nothing.
+  , _event_currentValue :: WeakMutVarOutput (Maybe a) -- Allows seeing the current state of the event: if Nothing, it either isn't firing or hasn't fired yet this frame; if Just, it has fired this frame.
+  --TODO: Position in topological ordering; only needed when we introduce Merge
+  }
+
+data Trigger a = Trigger
+  { _trigger_items :: WeakBagOutput (a -> IO ()) -- Allows retrieving the contents of the weak bag
+  , _trigger_currentValue :: WeakMutVarInput (Maybe a)
+  }
+
+newEvent :: IO (Trigger a, Event a)
+newEvent = undefined
+
+fireTrigger :: Trigger a -> a -> IO ()
+fireTrigger = undefined
+
+data Hold a = Hold
+  {
+  }
+
+newHold :: a -> Event a -> IO (Hold a)
+newHold = undefined
+
 -- Demonstrate that a Weak's key keeps its value alive, even if the Weak is dead
 testWeakChain :: IO ()
 testWeakChain = do