diff --git a/main.hs b/main.hs index 92fd91c..119aed9 100644 --- a/main.hs +++ b/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