{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Concoct.View.Tree
-- Copyright   : (c) Matt Hunzinger, 2026
-- License     : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  : matt@hunzinger.me
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Concoct.View.Tree
  ( ViewTree (..),
    viewTree,
    rebuildViewTree,
    unmountViewTree,
  )
where

import Concoct.View.Build
import Concoct.View.Internal
import Concoct.View.Rebuild
import Concoct.View.Skip
import Concoct.View.Unmount
import Control.Monad.IO.Class
import Data.IORef

-- | View tree.
data ViewTree t = ViewTree
  { forall (t :: * -> *).
ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
viewTreeView :: forall m. (MonadView t m) => m (),
    forall (t :: * -> *). ViewTree t -> Stack
viewTreeStack :: Stack,
    forall (t :: * -> *). ViewTree t -> IORef Bool
viewTreeChanged :: IORef Bool,
    forall (t :: * -> *). ViewTree t -> IORef (IO ())
viewTreePendingUpdates :: IORef (IO ())
  }

-- | Create a view tree from a view.
viewTree :: (MonadIO t) => (forall m. (MonadView t m) => m ()) -> t (ViewTree t)
viewTree :: forall (t :: * -> *).
MonadIO t =>
(forall (m :: * -> *). MonadView t m => m ()) -> t (ViewTree t)
viewTree forall (m :: * -> *). MonadView t m => m ()
v = do
  IORef Bool
changedRef <- IO (IORef Bool) -> t (IORef Bool)
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> t (IORef Bool))
-> IO (IORef Bool) -> t (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IORef (IO ())
pendingRef <- IO (IORef (IO ())) -> t (IORef (IO ()))
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (IO ())) -> t (IORef (IO ())))
-> IO (IORef (IO ())) -> t (IORef (IO ()))
forall a b. (a -> b) -> a -> b
$ IO () -> IO (IORef (IO ()))
forall a. a -> IO (IORef a)
newIORef (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  let updater :: IO () -> IO ()
updater IO ()
m = IORef (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (IO ())
pendingRef (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
changedRef Bool
True
      s :: ViewState
s = Stack -> (IO () -> IO ()) -> ViewState
ViewState Stack
emptyStack IO () -> IO ()
updater
  (()
_, ViewState
s') <- Build t () -> ViewState -> t ((), ViewState)
forall (m :: * -> *) a.
MonadIO m =>
Build m a -> ViewState -> m (a, ViewState)
runBuild Build t ()
forall (m :: * -> *). MonadView t m => m ()
v ViewState
s
  ViewTree t -> t (ViewTree t)
forall a. a -> t a
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (m :: * -> *). MonadView t m => m ())
-> Stack -> IORef Bool -> IORef (IO ()) -> ViewTree t
forall (t :: * -> *).
(forall (m :: * -> *). MonadView t m => m ())
-> Stack -> IORef Bool -> IORef (IO ()) -> ViewTree t
ViewTree m ()
forall (m :: * -> *). MonadView t m => m ()
v (Stack -> Stack
flushStack (Stack -> Stack) -> Stack -> Stack
forall a b. (a -> b) -> a -> b
$ ViewState -> Stack
viewStack ViewState
s') IORef Bool
changedRef IORef (IO ())
pendingRef)

-- | Rebuild the view tree if changed.
rebuildViewTree :: (MonadIO t) => ViewTree t -> t (ViewTree t)
rebuildViewTree :: forall (t :: * -> *). MonadIO t => ViewTree t -> t (ViewTree t)
rebuildViewTree ViewTree t
t = do
  IO ()
pending <- IO (IO ()) -> t (IO ())
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO ()) -> t (IO ())) -> IO (IO ()) -> t (IO ())
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef (ViewTree t -> IORef (IO ())
forall (t :: * -> *). ViewTree t -> IORef (IO ())
viewTreePendingUpdates ViewTree t
t)
  IO () -> t ()
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
pending
  IO () -> t ()
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> t ()) -> IO () -> t ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ViewTree t -> IORef (IO ())
forall (t :: * -> *). ViewTree t -> IORef (IO ())
viewTreePendingUpdates ViewTree t
t) (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Bool
changed <- IO Bool -> t Bool
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> t Bool) -> IO Bool -> t Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (ViewTree t -> IORef Bool
forall (t :: * -> *). ViewTree t -> IORef Bool
viewTreeChanged ViewTree t
t)
  if Bool
changed
    then do
      IO () -> t ()
forall a. IO a -> t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> t ()) -> IO () -> t ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ViewTree t -> IORef Bool
forall (t :: * -> *). ViewTree t -> IORef Bool
viewTreeChanged ViewTree t
t) Bool
False
      let updater :: IO () -> IO ()
updater IO ()
m = IORef (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ViewTree t -> IORef (IO ())
forall (t :: * -> *). ViewTree t -> IORef (IO ())
viewTreePendingUpdates ViewTree t
t) (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ViewTree t -> IORef Bool
forall (t :: * -> *). ViewTree t -> IORef Bool
viewTreeChanged ViewTree t
t) Bool
True
          s :: ViewState
s = Stack -> (IO () -> IO ()) -> ViewState
ViewState (ViewTree t -> Stack
forall (t :: * -> *). ViewTree t -> Stack
viewTreeStack ViewTree t
t) IO () -> IO ()
updater
      (()
_, ViewState
s') <- Rebuild t () -> ViewState -> t ((), ViewState)
forall (m :: * -> *) a.
MonadIO m =>
Rebuild m a -> ViewState -> m (a, ViewState)
runRebuild (ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
forall (t :: * -> *).
ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
viewTreeView ViewTree t
t) ViewState
s
      ViewTree t -> t (ViewTree t)
forall a. a -> t a
forall (m :: * -> *) a. Monad m => a -> m a
return ViewTree t
t {viewTreeStack = flushStack $ viewStack s'}
    else do
      let updater :: IO () -> IO ()
updater IO ()
m = IORef (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef (ViewTree t -> IORef (IO ())
forall (t :: * -> *). ViewTree t -> IORef (IO ())
viewTreePendingUpdates ViewTree t
t) (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ViewTree t -> IORef Bool
forall (t :: * -> *). ViewTree t -> IORef Bool
viewTreeChanged ViewTree t
t) Bool
True
          s :: ViewState
s = Stack -> (IO () -> IO ()) -> ViewState
ViewState (ViewTree t -> Stack
forall (t :: * -> *). ViewTree t -> Stack
viewTreeStack ViewTree t
t) IO () -> IO ()
updater
      (()
_, ViewState
s') <- Skip t () -> ViewState -> t ((), ViewState)
forall (m :: * -> *) a.
MonadIO m =>
Skip m a -> ViewState -> m (a, ViewState)
runSkip (ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
forall (t :: * -> *).
ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
viewTreeView ViewTree t
t) ViewState
s
      ViewTree t -> t (ViewTree t)
forall a. a -> t a
forall (m :: * -> *) a. Monad m => a -> m a
return ViewTree t
t {viewTreeStack = flushStack $ viewStack s'}

-- | Unmount the view tree.
unmountViewTree :: (MonadIO t) => ViewTree t -> t (ViewTree t)
unmountViewTree :: forall (t :: * -> *). MonadIO t => ViewTree t -> t (ViewTree t)
unmountViewTree ViewTree t
t = do
  (()
_, Stack
stack') <- Unmount t () -> Stack -> t ((), Stack)
forall (m :: * -> *) a.
MonadIO m =>
Unmount m a -> Stack -> m (a, Stack)
runUnmount (ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
forall (t :: * -> *).
ViewTree t -> forall (m :: * -> *). MonadView t m => m ()
viewTreeView ViewTree t
t) (ViewTree t -> Stack
forall (t :: * -> *). ViewTree t -> Stack
viewTreeStack ViewTree t
t)
  ViewTree t -> t (ViewTree t)
forall a. a -> t a
forall (m :: * -> *) a. Monad m => a -> m a
return ViewTree t
t {viewTreeStack = stack'}