{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Concoct.View.Unmount
-- 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.Unmount (Unmount (..), runUnmount) where

import Concoct.View.Internal
import Control.Monad.State

newtype Unmount m a = Unmount {forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount :: StateT Stack m a}
  deriving ((forall a b. (a -> b) -> Unmount m a -> Unmount m b)
-> (forall a b. a -> Unmount m b -> Unmount m a)
-> Functor (Unmount m)
forall a b. a -> Unmount m b -> Unmount m a
forall a b. (a -> b) -> Unmount m a -> Unmount m b
forall (m :: * -> *) a b.
Functor m =>
a -> Unmount m b -> Unmount m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Unmount m a -> Unmount m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Unmount m a -> Unmount m b
fmap :: forall a b. (a -> b) -> Unmount m a -> Unmount m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Unmount m b -> Unmount m a
<$ :: forall a b. a -> Unmount m b -> Unmount m a
Functor, Functor (Unmount m)
Functor (Unmount m) =>
(forall a. a -> Unmount m a)
-> (forall a b. Unmount m (a -> b) -> Unmount m a -> Unmount m b)
-> (forall a b c.
    (a -> b -> c) -> Unmount m a -> Unmount m b -> Unmount m c)
-> (forall a b. Unmount m a -> Unmount m b -> Unmount m b)
-> (forall a b. Unmount m a -> Unmount m b -> Unmount m a)
-> Applicative (Unmount m)
forall a. a -> Unmount m a
forall a b. Unmount m a -> Unmount m b -> Unmount m a
forall a b. Unmount m a -> Unmount m b -> Unmount m b
forall a b. Unmount m (a -> b) -> Unmount m a -> Unmount m b
forall a b c.
(a -> b -> c) -> Unmount m a -> Unmount m b -> Unmount m c
forall (m :: * -> *). Monad m => Functor (Unmount m)
forall (m :: * -> *) a. Monad m => a -> Unmount m a
forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m a
forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m b
forall (m :: * -> *) a b.
Monad m =>
Unmount m (a -> b) -> Unmount m a -> Unmount m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Unmount m a -> Unmount m b -> Unmount m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> Unmount m a
pure :: forall a. a -> Unmount m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Unmount m (a -> b) -> Unmount m a -> Unmount m b
<*> :: forall a b. Unmount m (a -> b) -> Unmount m a -> Unmount m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Unmount m a -> Unmount m b -> Unmount m c
liftA2 :: forall a b c.
(a -> b -> c) -> Unmount m a -> Unmount m b -> Unmount m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m b
*> :: forall a b. Unmount m a -> Unmount m b -> Unmount m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m a
<* :: forall a b. Unmount m a -> Unmount m b -> Unmount m a
Applicative, Applicative (Unmount m)
Applicative (Unmount m) =>
(forall a b. Unmount m a -> (a -> Unmount m b) -> Unmount m b)
-> (forall a b. Unmount m a -> Unmount m b -> Unmount m b)
-> (forall a. a -> Unmount m a)
-> Monad (Unmount m)
forall a. a -> Unmount m a
forall a b. Unmount m a -> Unmount m b -> Unmount m b
forall a b. Unmount m a -> (a -> Unmount m b) -> Unmount m b
forall (m :: * -> *). Monad m => Applicative (Unmount m)
forall (m :: * -> *) a. Monad m => a -> Unmount m a
forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m b
forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> (a -> Unmount m b) -> Unmount m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> (a -> Unmount m b) -> Unmount m b
>>= :: forall a b. Unmount m a -> (a -> Unmount m b) -> Unmount m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Unmount m a -> Unmount m b -> Unmount m b
>> :: forall a b. Unmount m a -> Unmount m b -> Unmount m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Unmount m a
return :: forall a. a -> Unmount m a
Monad)

instance (MonadIO m) => MonadView m (Unmount m) where
  useState :: forall a. Typeable a => m a -> Unmount m (StateRef a)
useState m a
_ = StateT Stack m (StateRef a) -> Unmount m (StateRef a)
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m (StateRef a) -> Unmount m (StateRef a))
-> StateT Stack m (StateRef a) -> Unmount m (StateRef a)
forall a b. (a -> b) -> a -> b
$ do
    Stack
stack <- StateT Stack m Stack
forall s (m :: * -> *). MonadState s m => m s
get
    let (StateRef a
ref, Stack
stack') = Stack -> (StateRef a, Stack)
forall a. Typeable a => Stack -> (StateRef a, Stack)
rebuildState' Stack
stack
    Stack -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Stack
stack'
    StateRef a -> StateT Stack m (StateRef a)
forall a. a -> StateT Stack m a
forall (m :: * -> *) a. Monad m => a -> m a
return StateRef a
ref
  useRef :: forall a. Typeable a => m a -> Unmount m (ViewRef a)
useRef m a
_ = StateT Stack m (ViewRef a) -> Unmount m (ViewRef a)
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m (ViewRef a) -> Unmount m (ViewRef a))
-> StateT Stack m (ViewRef a) -> Unmount m (ViewRef a)
forall a b. (a -> b) -> a -> b
$ do
    Stack
stack <- StateT Stack m Stack
forall s (m :: * -> *). MonadState s m => m s
get
    let (ViewRef a
ref, Stack
stack') = Stack -> (ViewRef a, Stack)
forall a. Typeable a => Stack -> (ViewRef a, Stack)
rebuildRef' Stack
stack
    Stack -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Stack
stack'
    ViewRef a -> StateT Stack m (ViewRef a)
forall a. a -> StateT Stack m a
forall (m :: * -> *) a. Monad m => a -> m a
return ViewRef a
ref
  useEffect :: forall d. (Eq d, Typeable d) => m d -> (d -> m ()) -> Unmount m ()
useEffect m d
_ d -> m ()
_ = StateT Stack m () -> Unmount m ()
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m () -> Unmount m ())
-> StateT Stack m () -> Unmount m ()
forall a b. (a -> b) -> a -> b
$ (Stack -> Stack) -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Stack -> Stack
skipStack
  useOnUnmount :: m () -> Unmount m ()
useOnUnmount = StateT Stack m () -> Unmount m ()
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m () -> Unmount m ())
-> (m () -> StateT Stack m ()) -> m () -> Unmount m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> StateT Stack m ()
forall (m :: * -> *) a. Monad m => m a -> StateT Stack m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
  component :: (forall (x :: * -> *). MonadView m x => x ()) -> Unmount m ()
component forall (x :: * -> *). MonadView m x => x ()
v = StateT Stack m () -> Unmount m ()
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m () -> Unmount m ())
-> StateT Stack m () -> Unmount m ()
forall a b. (a -> b) -> a -> b
$ do
    (Stack -> Stack) -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Stack -> Stack
skipStack
    Unmount m () -> StateT Stack m ()
forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount Unmount m ()
forall (x :: * -> *). MonadView m x => x ()
v
  liftView :: m () -> Unmount m ()
liftView m ()
_ = () -> Unmount m ()
forall a. a -> Unmount m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  switchView :: m Bool
-> (forall (x :: * -> *). MonadView m x => x ())
-> (forall (x :: * -> *). MonadView m x => x ())
-> Unmount m ()
switchView m Bool
_ forall (x :: * -> *). MonadView m x => x ()
vTrue forall (x :: * -> *). MonadView m x => x ()
vFalse = StateT Stack m () -> Unmount m ()
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m () -> Unmount m ())
-> StateT Stack m () -> Unmount m ()
forall a b. (a -> b) -> a -> b
$ do
    Stack
stack <- StateT Stack m Stack
forall s (m :: * -> *). MonadState s m => m s
get
    let (Maybe Bool
mcond, Stack
stack') = Stack -> (Maybe Bool, Stack)
forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack Stack
stack
    Stack -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Stack
stack'
    case Maybe Bool
mcond of
      Just Bool
cond' -> if Bool
cond' then Unmount m () -> StateT Stack m ()
forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount Unmount m ()
forall (x :: * -> *). MonadView m x => x ()
vTrue else Unmount m () -> StateT Stack m ()
forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount Unmount m ()
forall (x :: * -> *). MonadView m x => x ()
vFalse
      Maybe Bool
Nothing -> [Char] -> StateT Stack m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"switchView: Condition not found in stack during unmount"
  listView :: forall a.
(Typeable a, Eq a) =>
m [a]
-> (a -> forall (x :: * -> *). MonadView m x => x ())
-> Unmount m ()
listView m [a]
_ a -> forall (x :: * -> *). MonadView m x => x ()
f = StateT Stack m () -> Unmount m ()
forall (m :: * -> *) a. StateT Stack m a -> Unmount m a
Unmount (StateT Stack m () -> Unmount m ())
-> StateT Stack m () -> Unmount m ()
forall a b. (a -> b) -> a -> b
$ do
    Stack
stack <- StateT Stack m Stack
forall s (m :: * -> *). MonadState s m => m s
get
    let (Maybe [a]
mItems, Stack
stack') = forall a. Typeable a => Stack -> (Maybe a, Stack)
popStack @[_] Stack
stack
    Stack -> StateT Stack m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Stack
stack'
    case Maybe [a]
mItems of
      Just [a]
items' -> (a -> StateT Stack m ()) -> [a] -> StateT Stack m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Unmount m () -> StateT Stack m ()
forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount (Unmount m () -> StateT Stack m ())
-> (a -> Unmount m ()) -> a -> StateT Stack m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Unmount m ()
a -> forall (x :: * -> *). MonadView m x => x ()
f) [a]
items'
      Maybe [a]
Nothing -> [Char] -> StateT Stack m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"listView: Items not found in stack during unmount"

runUnmount :: (MonadIO m) => Unmount m a -> Stack -> m (a, Stack)
runUnmount :: forall (m :: * -> *) a.
MonadIO m =>
Unmount m a -> Stack -> m (a, Stack)
runUnmount Unmount m a
vu = StateT Stack m a -> Stack -> m (a, Stack)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Unmount m a -> StateT Stack m a
forall (m :: * -> *) a. Unmount m a -> StateT Stack m a
unUnmount Unmount m a
vu)