{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Module      : Concoct.View.Internal
-- 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.Internal
  ( -- * MonadView
    MonadView (..),

    -- * StateRef
    StateRef (..),
    readStateRef,
    writeStateRef,

    -- * ViewRef
    ViewRef (..),
    readViewRef,

    -- * Stack
    Stack (..),
    emptyStack,
    pushStack,
    popStack,
    peekStack,
    setStack,
    skipStack,
    flushStack,

    -- * ViewState
    ViewState (..),
    rebuildState,
    rebuildState',
    rebuildRef,
    rebuildRef',
    rebuildComponent,
  )
where

import Control.Monad
import Control.Monad.State
import Data.Dynamic
import Data.IORef

-- | Monadic view.
--
-- Views are interpreted in multiple passes:
--
-- * Build
-- * Rebuild
-- * Skip
-- * Unmount
--
-- And can be extended for further passes, such as layout or render.
--
-- Hooks provide access to values in a view across passes.
--
-- Views are seperated into @component@s, with each providing a scope for updates to occur.
-- A @component@ will only be rebuilt if its state is changed.
-- If a component containing children is updated, its children are rebuilt as well.
class (Monad m) => MonadView t m | m -> t where
  -- | Hook to use a mutable state reference.
  useState :: (Typeable a) => t a -> m (StateRef a)

  -- | Hook to use a constant view reference.
  useRef :: (Typeable a) => t a -> m (ViewRef a)

  -- | Hook to use an effect that runs when dependencies change.
  useEffect :: (Eq d, Typeable d) => t d -> (d -> t ()) -> m ()

  -- | Hook that runs when the current component is unmounted.
  useOnUnmount :: t () -> m ()

  -- | Component view.
  component :: (forall x. (MonadView t x) => x ()) -> m ()

  -- | Lift a monadic action into the view.
  liftView :: t () -> m ()

  -- | Conditional view.
  -- This will render the first view if the condition is @True@, otherwise the second.
  switchView ::
    t Bool ->
    (forall x. (MonadView t x) => x ()) ->
    (forall x. (MonadView t x) => x ()) ->
    m ()

  -- | List view.
  -- This will render a view for each item in the list.
  listView :: (Typeable a, Eq a) => t [a] -> (a -> (forall x. (MonadView t x) => x ())) -> m ()

-- | State reference.
-- Created with @useState@.
data StateRef a = StateRef
  { forall a. StateRef a -> IORef a
stateRef :: IORef a,
    forall a. StateRef a -> IO () -> IO ()
stateRefUpdater :: IO () -> IO ()
  }

-- | Read a state reference.
readStateRef :: (MonadIO m) => StateRef a -> m a
readStateRef :: forall (m :: * -> *) a. MonadIO m => StateRef a -> m a
readStateRef = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (StateRef a -> IO a) -> StateRef a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef a -> IO a
forall a. IORef a -> IO a
readIORef (IORef a -> IO a) -> (StateRef a -> IORef a) -> StateRef a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef a -> IORef a
forall a. StateRef a -> IORef a
stateRef

-- | Write to a state reference.
-- This will schedule an update to the current @component@.
writeStateRef :: (MonadIO m) => StateRef a -> a -> m ()
writeStateRef :: forall (m :: * -> *) a. MonadIO m => StateRef a -> a -> m ()
writeStateRef StateRef a
ref = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateRef a -> IO () -> IO ()
forall a. StateRef a -> IO () -> IO ()
stateRefUpdater StateRef a
ref (IO () -> IO ()) -> (a -> IO ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (StateRef a -> IORef a
forall a. StateRef a -> IORef a
stateRef StateRef a
ref)

-- | View reference.
-- Created with @useRef@.
newtype ViewRef a = ViewRef a

-- | Read a view reference.
readViewRef :: (Applicative m) => ViewRef a -> m a
readViewRef :: forall (m :: * -> *) a. Applicative m => ViewRef a -> m a
readViewRef (ViewRef a
a) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

data Stack = Stack
  { Stack -> [Dynamic]
stackBefore :: [Dynamic],
    Stack -> [Dynamic]
stackAfter :: [Dynamic]
  }

emptyStack :: Stack
emptyStack :: Stack
emptyStack = [Dynamic] -> [Dynamic] -> Stack
Stack [] []

pushStack :: (Typeable a) => a -> Stack -> Stack
pushStack :: forall a. Typeable a => a -> Stack -> Stack
pushStack a
a (Stack [Dynamic]
before [Dynamic]
after) = [Dynamic] -> [Dynamic] -> Stack
Stack (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a Dynamic -> [Dynamic] -> [Dynamic]
forall a. a -> [a] -> [a]
: [Dynamic]
before) [Dynamic]
after

popStack :: (Typeable a) => Stack -> (Maybe a, Stack)
popStack :: forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack (Stack [Dynamic]
before []) = (Maybe a
forall a. Maybe a
Nothing, [Dynamic] -> [Dynamic] -> Stack
Stack [Dynamic]
before [])
popStack (Stack [Dynamic]
before (Dynamic
d : [Dynamic]
ds)) =
  case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
d of
    Just a
a -> (a -> Maybe a
forall a. a -> Maybe a
Just a
a, [Dynamic] -> [Dynamic] -> Stack
Stack (Dynamic
d Dynamic -> [Dynamic] -> [Dynamic]
forall a. a -> [a] -> [a]
: [Dynamic]
before) [Dynamic]
ds)
    Maybe a
Nothing -> Stack -> (Maybe a, Stack)
forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack ([Dynamic] -> [Dynamic] -> Stack
Stack (Dynamic
d Dynamic -> [Dynamic] -> [Dynamic]
forall a. a -> [a] -> [a]
: [Dynamic]
before) [Dynamic]
ds)

peekStack :: (Typeable a) => Stack -> Maybe a
peekStack :: forall a. Typeable a => Stack -> Maybe a
peekStack (Stack [Dynamic]
_ []) = Maybe a
forall a. Maybe a
Nothing
peekStack (Stack [Dynamic]
_ (Dynamic
d : [Dynamic]
_)) = Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
d

setStack :: (Typeable a) => a -> Stack -> Stack
setStack :: forall a. Typeable a => a -> Stack -> Stack
setStack a
a (Stack [Dynamic]
before (Dynamic
_ : [Dynamic]
ds)) = [Dynamic] -> [Dynamic] -> Stack
Stack (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a Dynamic -> [Dynamic] -> [Dynamic]
forall a. a -> [a] -> [a]
: [Dynamic]
before) [Dynamic]
ds
setStack a
_ Stack
s = Stack
s

skipStack :: Stack -> Stack
skipStack :: Stack -> Stack
skipStack (Stack [Dynamic]
before (Dynamic
d : [Dynamic]
after)) = [Dynamic] -> [Dynamic] -> Stack
Stack (Dynamic
d Dynamic -> [Dynamic] -> [Dynamic]
forall a. a -> [a] -> [a]
: [Dynamic]
before) [Dynamic]
after
skipStack Stack
s = Stack
s

flushStack :: Stack -> Stack
flushStack :: Stack -> Stack
flushStack (Stack [Dynamic]
before [Dynamic]
after) = [Dynamic] -> [Dynamic] -> Stack
Stack [] ([Dynamic] -> [Dynamic]
forall a. [a] -> [a]
reverse [Dynamic]
before [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
after)

data ViewState = ViewState
  { ViewState -> Stack
viewStack :: Stack,
    ViewState -> IO () -> IO ()
viewUpdater :: IO () -> IO ()
  }

rebuildState :: (MonadIO m, Typeable a) => StateT ViewState m (StateRef a)
rebuildState :: forall (m :: * -> *) a.
(MonadIO m, Typeable a) =>
StateT ViewState m (StateRef a)
rebuildState = do
  ViewState
vs <- StateT ViewState m ViewState
forall s (m :: * -> *). MonadState s m => m s
get
  let (StateRef a
ref, Stack
s') = Stack -> (StateRef a, Stack)
forall a. Typeable a => Stack -> (StateRef a, Stack)
rebuildState' (ViewState -> Stack
viewStack ViewState
vs)
  ViewState -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ViewState
vs {viewStack = s'}
  StateRef a -> StateT ViewState m (StateRef a)
forall a. a -> StateT ViewState m a
forall (m :: * -> *) a. Monad m => a -> m a
return StateRef a
ref

rebuildState' :: (Typeable a) => Stack -> (StateRef a, Stack)
rebuildState' :: forall a. Typeable a => Stack -> (StateRef a, Stack)
rebuildState' Stack
s = do
  let (Maybe (StateRef a)
mref, Stack
s') = Stack -> (Maybe (StateRef a), Stack)
forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack Stack
s
  case Maybe (StateRef a)
mref of
    Just StateRef a
ref -> (StateRef a
ref, Stack
s')
    Maybe (StateRef a)
Nothing -> [Char] -> (StateRef a, Stack)
forall a. HasCallStack => [Char] -> a
error [Char]
"useState: StateRef not found in stack during rebuild"

rebuildRef :: (Monad m, Typeable a) => StateT ViewState m (ViewRef a)
rebuildRef :: forall (m :: * -> *) a.
(Monad m, Typeable a) =>
StateT ViewState m (ViewRef a)
rebuildRef = do
  ViewState
vs <- StateT ViewState m ViewState
forall s (m :: * -> *). MonadState s m => m s
get
  let (ViewRef a
ref, Stack
s') = Stack -> (ViewRef a, Stack)
forall a. Typeable a => Stack -> (ViewRef a, Stack)
rebuildRef' (ViewState -> Stack
viewStack ViewState
vs)
  ViewState -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ViewState
vs {viewStack = s'}
  ViewRef a -> StateT ViewState m (ViewRef a)
forall a. a -> StateT ViewState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ViewRef a
ref

rebuildRef' :: (Typeable a) => Stack -> (ViewRef a, Stack)
rebuildRef' :: forall a. Typeable a => Stack -> (ViewRef a, Stack)
rebuildRef' Stack
s = do
  let (Maybe (ViewRef a)
mref, Stack
s') = Stack -> (Maybe (ViewRef a), Stack)
forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack Stack
s
  case Maybe (ViewRef a)
mref of
    Just ViewRef a
ref -> (ViewRef a
ref, Stack
s')
    Maybe (ViewRef a)
Nothing -> [Char] -> (ViewRef a, Stack)
forall a. HasCallStack => [Char] -> a
error [Char]
"useRef: ViewRef not found in stack during rebuild"

rebuildComponent ::
  (MonadIO m, MonadView t f) =>
  (f () -> StateT ViewState m ()) ->
  (forall x. (MonadView t x) => x ()) ->
  StateT ViewState m ()
rebuildComponent :: forall (m :: * -> *) (t :: * -> *) (f :: * -> *).
(MonadIO m, MonadView t f) =>
(f () -> StateT ViewState m ())
-> (forall (x :: * -> *). MonadView t x => x ())
-> StateT ViewState m ()
rebuildComponent f () -> StateT ViewState m ()
g forall (x :: * -> *). MonadView t x => x ()
v = do
  ViewState
vs <- StateT ViewState m ViewState
forall s (m :: * -> *). MonadState s m => m s
get
  let (Maybe (IORef Bool)
mref, Stack
s') = Stack -> (Maybe (IORef Bool), Stack)
forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack (ViewState -> Stack
viewStack ViewState
vs)
  ViewState -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ViewState
vs {viewStack = s'}
  case Maybe (IORef Bool)
mref of
    Just IORef Bool
ref -> do
      Bool
changed <- IO Bool -> StateT ViewState m Bool
forall a. IO a -> StateT ViewState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT ViewState m Bool)
-> IO Bool -> StateT ViewState m Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref
      Bool -> StateT ViewState m () -> StateT ViewState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (StateT ViewState m () -> StateT ViewState m ())
-> StateT ViewState m () -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT ViewState m ()
forall a. IO a -> StateT ViewState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT ViewState m ()) -> IO () -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ref Bool
False
      f () -> StateT ViewState m ()
g f ()
forall (x :: * -> *). MonadView t x => x ()
v
      ViewState
vs' <- StateT ViewState m ViewState
forall s (m :: * -> *). MonadState s m => m s
get
      ViewState -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ViewState
vs' {viewUpdater = viewUpdater vs}
    Maybe (IORef Bool)
Nothing -> [Char] -> StateT ViewState m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"component: Change ref not found in stack during rebuild"