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

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

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

newtype Build m a = Build {forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild :: StateT ViewState m a}
  deriving ((forall a b. (a -> b) -> Build m a -> Build m b)
-> (forall a b. a -> Build m b -> Build m a) -> Functor (Build m)
forall a b. a -> Build m b -> Build m a
forall a b. (a -> b) -> Build m a -> Build m b
forall (m :: * -> *) a b. Functor m => a -> Build m b -> Build m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Build m a -> Build 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) -> Build m a -> Build m b
fmap :: forall a b. (a -> b) -> Build m a -> Build m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Build m b -> Build m a
<$ :: forall a b. a -> Build m b -> Build m a
Functor, Functor (Build m)
Functor (Build m) =>
(forall a. a -> Build m a)
-> (forall a b. Build m (a -> b) -> Build m a -> Build m b)
-> (forall a b c.
    (a -> b -> c) -> Build m a -> Build m b -> Build m c)
-> (forall a b. Build m a -> Build m b -> Build m b)
-> (forall a b. Build m a -> Build m b -> Build m a)
-> Applicative (Build m)
forall a. a -> Build m a
forall a b. Build m a -> Build m b -> Build m a
forall a b. Build m a -> Build m b -> Build m b
forall a b. Build m (a -> b) -> Build m a -> Build m b
forall a b c. (a -> b -> c) -> Build m a -> Build m b -> Build m c
forall (m :: * -> *). Monad m => Functor (Build m)
forall (m :: * -> *) a. Monad m => a -> Build m a
forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m a
forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m b
forall (m :: * -> *) a b.
Monad m =>
Build m (a -> b) -> Build m a -> Build m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Build m a -> Build m b -> Build 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 -> Build m a
pure :: forall a. a -> Build m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Build m (a -> b) -> Build m a -> Build m b
<*> :: forall a b. Build m (a -> b) -> Build m a -> Build m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Build m a -> Build m b -> Build m c
liftA2 :: forall a b c. (a -> b -> c) -> Build m a -> Build m b -> Build m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m b
*> :: forall a b. Build m a -> Build m b -> Build m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m a
<* :: forall a b. Build m a -> Build m b -> Build m a
Applicative, Applicative (Build m)
Applicative (Build m) =>
(forall a b. Build m a -> (a -> Build m b) -> Build m b)
-> (forall a b. Build m a -> Build m b -> Build m b)
-> (forall a. a -> Build m a)
-> Monad (Build m)
forall a. a -> Build m a
forall a b. Build m a -> Build m b -> Build m b
forall a b. Build m a -> (a -> Build m b) -> Build m b
forall (m :: * -> *). Monad m => Applicative (Build m)
forall (m :: * -> *) a. Monad m => a -> Build m a
forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m b
forall (m :: * -> *) a b.
Monad m =>
Build m a -> (a -> Build m b) -> Build 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 =>
Build m a -> (a -> Build m b) -> Build m b
>>= :: forall a b. Build m a -> (a -> Build m b) -> Build m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Build m a -> Build m b -> Build m b
>> :: forall a b. Build m a -> Build m b -> Build m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Build m a
return :: forall a. a -> Build m a
Monad)

instance (MonadIO m) => MonadView m (Build m) where
  useState :: forall a. Typeable a => m a -> Build m (StateRef a)
useState m a
a = StateT ViewState m (StateRef a) -> Build m (StateRef a)
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m (StateRef a) -> Build m (StateRef a))
-> StateT ViewState m (StateRef a) -> Build m (StateRef a)
forall a b. (a -> b) -> a -> b
$ do
    a
a' <- m a -> StateT ViewState m a
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
a
    IORef a
ref <- IO (IORef a) -> StateT ViewState m (IORef a)
forall a. IO a -> StateT ViewState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef a) -> StateT ViewState m (IORef a))
-> IO (IORef a) -> StateT ViewState m (IORef a)
forall a b. (a -> b) -> a -> b
$ a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a'
    ViewState
vs <- StateT ViewState m ViewState
forall s (m :: * -> *). MonadState s m => m s
get
    let sRef :: StateRef a
sRef = IORef a -> (IO () -> IO ()) -> StateRef a
forall a. IORef a -> (IO () -> IO ()) -> StateRef a
StateRef IORef a
ref ((IO () -> IO ()) -> StateRef a) -> (IO () -> IO ()) -> StateRef a
forall a b. (a -> b) -> a -> b
$ ViewState -> IO () -> IO ()
viewUpdater ViewState
vs
    ViewState -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ViewState
vs {viewStack = pushStack sRef (viewStack vs)}
    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
sRef
  useRef :: forall a. Typeable a => m a -> Build m (ViewRef a)
useRef m a
a = StateT ViewState m (ViewRef a) -> Build m (ViewRef a)
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m (ViewRef a) -> Build m (ViewRef a))
-> StateT ViewState m (ViewRef a) -> Build m (ViewRef a)
forall a b. (a -> b) -> a -> b
$ do
    a
a' <- m a -> StateT ViewState m a
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
a
    let vRef :: ViewRef a
vRef = a -> ViewRef a
forall a. a -> ViewRef a
ViewRef a
a'
    (ViewState -> ViewState) -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ViewState -> ViewState) -> StateT ViewState m ())
-> (ViewState -> ViewState) -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ \ViewState
vs -> ViewState
vs {viewStack = pushStack vRef (viewStack vs)}
    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
vRef
  useEffect :: forall d. (Eq d, Typeable d) => m d -> (d -> m ()) -> Build m ()
useEffect m d
deps d -> m ()
f = StateT ViewState m () -> Build m ()
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m () -> Build m ())
-> StateT ViewState m () -> Build m ()
forall a b. (a -> b) -> a -> b
$ do
    d
deps' <- m d -> StateT ViewState m d
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m d
deps
    (ViewState -> ViewState) -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ViewState -> ViewState) -> StateT ViewState m ())
-> (ViewState -> ViewState) -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ \ViewState
vs -> ViewState
vs {viewStack = pushStack deps' (viewStack vs)}
    m () -> StateT ViewState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT ViewState m ()) -> m () -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ d -> m ()
f d
deps'
  useOnUnmount :: m () -> Build m ()
useOnUnmount m ()
_ = () -> Build m ()
forall a. a -> Build m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  component :: (forall (x :: * -> *). MonadView m x => x ()) -> Build m ()
component forall (x :: * -> *). MonadView m x => x ()
vb = StateT ViewState m () -> Build m ()
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m () -> Build m ())
-> StateT ViewState m () -> Build m ()
forall a b. (a -> b) -> a -> b
$ do
    IORef Bool
ref <- IO (IORef Bool) -> StateT ViewState m (IORef Bool)
forall a. IO a -> StateT ViewState m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> StateT ViewState m (IORef Bool))
-> IO (IORef Bool) -> StateT ViewState m (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    let updater :: IO b -> IO b
updater IO b
m = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ref Bool
True IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
m
    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 = updater, viewStack = pushStack ref (viewStack vs)}
    Build m () -> StateT ViewState m ()
forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild Build m ()
forall (x :: * -> *). MonadView m x => x ()
vb
    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}
  liftView :: m () -> Build m ()
liftView = StateT ViewState m () -> Build m ()
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m () -> Build m ())
-> (m () -> StateT ViewState m ()) -> m () -> Build m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> StateT ViewState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
  switchView :: m Bool
-> (forall (x :: * -> *). MonadView m x => x ())
-> (forall (x :: * -> *). MonadView m x => x ())
-> Build m ()
switchView m Bool
cond forall (x :: * -> *). MonadView m x => x ()
vTrue forall (x :: * -> *). MonadView m x => x ()
vFalse = StateT ViewState m () -> Build m ()
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m () -> Build m ())
-> StateT ViewState m () -> Build m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
cond' <- m Bool -> StateT ViewState m Bool
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
cond
    (ViewState -> ViewState) -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ViewState -> ViewState) -> StateT ViewState m ())
-> (ViewState -> ViewState) -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ \ViewState
vs -> ViewState
vs {viewStack = pushStack cond' (viewStack vs)}
    if Bool
cond' then Build m () -> StateT ViewState m ()
forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild Build m ()
forall (x :: * -> *). MonadView m x => x ()
vTrue else Build m () -> StateT ViewState m ()
forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild Build m ()
forall (x :: * -> *). MonadView m x => x ()
vFalse
  listView :: forall a.
(Typeable a, Eq a) =>
m [a]
-> (a -> forall (x :: * -> *). MonadView m x => x ()) -> Build m ()
listView m [a]
items a -> forall (x :: * -> *). MonadView m x => x ()
f = StateT ViewState m () -> Build m ()
forall (m :: * -> *) a. StateT ViewState m a -> Build m a
Build (StateT ViewState m () -> Build m ())
-> StateT ViewState m () -> Build m ()
forall a b. (a -> b) -> a -> b
$ do
    [a]
items' <- m [a] -> StateT ViewState m [a]
forall (m :: * -> *) a. Monad m => m a -> StateT ViewState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [a]
items
    (ViewState -> ViewState) -> StateT ViewState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ViewState -> ViewState) -> StateT ViewState m ())
-> (ViewState -> ViewState) -> StateT ViewState m ()
forall a b. (a -> b) -> a -> b
$ \ViewState
vs -> ViewState
vs {viewStack = pushStack items' (viewStack vs)}
    (a -> StateT ViewState m ()) -> [a] -> StateT ViewState m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Build m () -> StateT ViewState m ()
forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild (Build m () -> StateT ViewState m ())
-> (a -> Build m ()) -> a -> StateT ViewState m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Build m ()
a -> forall (x :: * -> *). MonadView m x => x ()
f) [a]
items'

runBuild :: (MonadIO m) => Build m a -> ViewState -> m (a, ViewState)
runBuild :: forall (m :: * -> *) a.
MonadIO m =>
Build m a -> ViewState -> m (a, ViewState)
runBuild Build m a
vb = StateT ViewState m a -> ViewState -> m (a, ViewState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Build m a -> StateT ViewState m a
forall (m :: * -> *) a. Build m a -> StateT ViewState m a
unBuild Build m a
vb)