{-# options_haddock prune #-}

-- |An interpreter for 'GtkMain' that uses 'MVar's.
-- Internal.
module Helic.Interpreter.GtkMain where

import Polysemy.Conc (interpretScopedResumableH, interpretSync, interpretSyncAs, lock)
import qualified Polysemy.Conc.Sync as Sync

import qualified Helic.Effect.GtkMain as GtkMain
import Helic.Effect.GtkMain (GtkMain)
import Helic.GtkMain (gtkResource)

data GtkLock =
  GtkLock
  deriving stock (GtkLock -> GtkLock -> Bool
(GtkLock -> GtkLock -> Bool)
-> (GtkLock -> GtkLock -> Bool) -> Eq GtkLock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GtkLock -> GtkLock -> Bool
$c/= :: GtkLock -> GtkLock -> Bool
== :: GtkLock -> GtkLock -> Bool
$c== :: GtkLock -> GtkLock -> Bool
Eq, Int -> GtkLock -> ShowS
[GtkLock] -> ShowS
GtkLock -> String
(Int -> GtkLock -> ShowS)
-> (GtkLock -> String) -> ([GtkLock] -> ShowS) -> Show GtkLock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GtkLock] -> ShowS
$cshowList :: [GtkLock] -> ShowS
show :: GtkLock -> String
$cshow :: GtkLock -> String
showsPrec :: Int -> GtkLock -> ShowS
$cshowsPrec :: Int -> GtkLock -> ShowS
Show)

data StartGtkMain =
  StartGtkMain
  deriving stock (StartGtkMain -> StartGtkMain -> Bool
(StartGtkMain -> StartGtkMain -> Bool)
-> (StartGtkMain -> StartGtkMain -> Bool) -> Eq StartGtkMain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StartGtkMain -> StartGtkMain -> Bool
$c/= :: StartGtkMain -> StartGtkMain -> Bool
== :: StartGtkMain -> StartGtkMain -> Bool
$c== :: StartGtkMain -> StartGtkMain -> Bool
Eq, Int -> StartGtkMain -> ShowS
[StartGtkMain] -> ShowS
StartGtkMain -> String
(Int -> StartGtkMain -> ShowS)
-> (StartGtkMain -> String)
-> ([StartGtkMain] -> ShowS)
-> Show StartGtkMain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StartGtkMain] -> ShowS
$cshowList :: [StartGtkMain] -> ShowS
show :: StartGtkMain -> String
$cshow :: StartGtkMain -> String
showsPrec :: Int -> StartGtkMain -> ShowS
$cshowsPrec :: Int -> StartGtkMain -> ShowS
Show)

newtype GtkResource s =
  GtkResource { GtkResource s -> s
unGtkResource :: s }
  deriving stock (GtkResource s -> GtkResource s -> Bool
(GtkResource s -> GtkResource s -> Bool)
-> (GtkResource s -> GtkResource s -> Bool) -> Eq (GtkResource s)
forall s. Eq s => GtkResource s -> GtkResource s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GtkResource s -> GtkResource s -> Bool
$c/= :: forall s. Eq s => GtkResource s -> GtkResource s -> Bool
== :: GtkResource s -> GtkResource s -> Bool
$c== :: forall s. Eq s => GtkResource s -> GtkResource s -> Bool
Eq, Int -> GtkResource s -> ShowS
[GtkResource s] -> ShowS
GtkResource s -> String
(Int -> GtkResource s -> ShowS)
-> (GtkResource s -> String)
-> ([GtkResource s] -> ShowS)
-> Show (GtkResource s)
forall s. Show s => Int -> GtkResource s -> ShowS
forall s. Show s => [GtkResource s] -> ShowS
forall s. Show s => GtkResource s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GtkResource s] -> ShowS
$cshowList :: forall s. Show s => [GtkResource s] -> ShowS
show :: GtkResource s -> String
$cshow :: forall s. Show s => GtkResource s -> String
showsPrec :: Int -> GtkResource s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> GtkResource s -> ShowS
Show)

-- TODO Access needs to be a scope to ensure it must be executed
-- this means that access/request and run/running must be two separate effects

-- |Interpret the GTK main loop communication bridge with 'MVar's.
handleGtkMain ::
  ∀ s wait restart e m r a .
  TimeUnit wait =>
  TimeUnit restart =>
  Members [Resource, Sync GtkLock, Sync StartGtkMain, Sync (GtkResource s)] r =>
  wait ->
  restart ->
  GtkMain s m a ->
  Tactical e m r a
handleGtkMain :: wait -> restart -> GtkMain s m a -> Tactical e m r a
handleGtkMain wait
wait restart
restart = \case
  GtkMain.Access m s
ms -> do
    GtkLock
-> Sem (WithTactics e f m r) (f s)
-> Sem (WithTactics e f m r) (f s)
forall l (r :: EffectRow) a.
Members '[Sync l, Resource] r =>
l -> Sem r a -> Sem r a
lock GtkLock
GtkLock do
      Sem (WithTactics e f m r) (Maybe (GtkResource s))
forall d (r :: EffectRow). Member (Sync d) r => Sem r (Maybe d)
Sync.try Sem (WithTactics e f m r) (Maybe (GtkResource s))
-> (Maybe (GtkResource s) -> Sem (WithTactics e f m r) (f s))
-> Sem (WithTactics e f m r) (f s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (GtkResource s
s) ->
          s -> Sem (WithTactics e f m r) (f s)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT s
s
        Maybe (GtkResource s)
Nothing ->
          m s -> Tactical e m r s
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m s
ms
  GtkMain.Request m s
ms -> do
    forall (r :: EffectRow).
Member (Sync (GtkResource s)) r =>
Sem r ()
forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
    StartGtkMain -> Sem (WithTactics e f m r) Bool
forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r Bool
Sync.putTry StartGtkMain
StartGtkMain
    wait -> Sem (WithTactics e f m r) (Maybe (GtkResource s))
forall d (r :: EffectRow) u.
(Member (Sync d) r, TimeUnit u) =>
u -> Sem r (Maybe d)
Sync.wait wait
wait Sem (WithTactics e f m r) (Maybe (GtkResource s))
-> (Maybe (GtkResource s) -> Sem (WithTactics e f m r) (f s))
-> Sem (WithTactics e f m r) (f s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (GtkResource s
s) ->
        s -> Sem (WithTactics e f m r) (f s)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT s
s
      Maybe (GtkResource s)
Nothing ->
        m s -> Tactical e m r s
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m s
ms
  GtkMain.Run m a
ma -> do
    forall (r :: EffectRow). Member (Sync StartGtkMain) r => Sem r ()
forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @StartGtkMain
    forall (r :: EffectRow).
Member (Sync (GtkResource s)) r =>
Sem r ()
forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
    m a -> Tactical e m r a
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m a
ma Sem (WithTactics e f m r) (f a)
-> Sem (WithTactics e f m r) (Maybe StartGtkMain)
-> Sem (WithTactics e f m r) (f a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* do
      forall (r :: EffectRow).
Member (Sync (GtkResource s)) r =>
Sem r ()
forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
      restart -> Sem (WithTactics e f m r) (Maybe StartGtkMain)
forall d (r :: EffectRow) u.
(Member (Sync d) r, TimeUnit u) =>
u -> Sem r (Maybe d)
Sync.takeWait @StartGtkMain restart
restart
  GtkMain.Running s
s ->
    () -> Sem (WithTactics e f m r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT (() -> Sem (WithTactics e f m r) (f ()))
-> Sem (WithTactics e f m r) () -> Sem (WithTactics e f m r) (f ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GtkResource s -> Sem (WithTactics e f m r) ()
forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r ()
Sync.putBlock (s -> GtkResource s
forall s. s -> GtkResource s
GtkResource s
s)

-- |Interpret the GTK main loop communication bridge with 'MVar's.
interpretGtkMain ::
  ∀ s wait restart r .
  TimeUnit wait =>
  TimeUnit restart =>
  Members [Resource, Race, Embed IO] r =>
  wait ->
  restart ->
  InterpreterFor (GtkMain s) r
interpretGtkMain :: wait -> restart -> InterpreterFor (GtkMain s) r
interpretGtkMain wait
wait restart
restart =
  Sem (Sync (GtkResource s) : r) a -> Sem r a
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync d) r
interpretSync (Sem (Sync (GtkResource s) : r) a -> Sem r a)
-> (Sem (GtkMain s : r) a -> Sem (Sync (GtkResource s) : r) a)
-> Sem (GtkMain s : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  GtkLock -> InterpreterFor (Sync GtkLock) (Sync (GtkResource s) : r)
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
d -> InterpreterFor (Sync d) r
interpretSyncAs GtkLock
GtkLock (Sem (Sync GtkLock : Sync (GtkResource s) : r) a
 -> Sem (Sync (GtkResource s) : r) a)
-> (Sem (GtkMain s : r) a
    -> Sem (Sync GtkLock : Sync (GtkResource s) : r) a)
-> Sem (GtkMain s : r) a
-> Sem (Sync (GtkResource s) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync StartGtkMain) r
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync d) r
interpretSync @StartGtkMain (Sem
   (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r) a
 -> Sem (Sync GtkLock : Sync (GtkResource s) : r) a)
-> (Sem (GtkMain s : r) a
    -> Sem
         (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r) a)
-> Sem (GtkMain s : r) a
-> Sem (Sync GtkLock : Sync (GtkResource s) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall (rInitial :: EffectRow) x.
 GtkMain s (Sem rInitial) x
 -> Tactical
      (GtkMain s)
      (Sem rInitial)
      (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
      x)
-> Sem
     (GtkMain s
        : Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
     a
-> Sem
     (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r) a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH (wait
-> restart
-> GtkMain s (Sem rInitial) x
-> Tactical
     (GtkMain s)
     (Sem rInitial)
     (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
     x
forall s wait restart (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow) a.
(TimeUnit wait, TimeUnit restart,
 Members
   '[Resource, Sync GtkLock, Sync StartGtkMain, Sync (GtkResource s)]
   r) =>
wait -> restart -> GtkMain s m a -> Tactical e m r a
handleGtkMain wait
wait restart
restart) (Sem
   (GtkMain s
      : Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
   a
 -> Sem
      (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r) a)
-> (Sem (GtkMain s : r) a
    -> Sem
         (GtkMain s
            : Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
         a)
-> Sem (GtkMain s : r) a
-> Sem
     (Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (GtkMain s : r) a
-> Sem
     (GtkMain s
        : Sync StartGtkMain : Sync GtkLock : Sync (GtkResource s) : r)
     a
forall (e2 :: (* -> *) -> * -> *) (e3 :: (* -> *) -> * -> *)
       (e4 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : e3 : e4 : r) a
raiseUnder3

-- |Scope an effect that uses a GTK main loop resource by acquiring it via 'GtkMain'.
interpretWithGtk ::
  ∀ e s r .
  Members [GtkMain s, Log] r =>
  (∀ r0 x . s -> e (Sem r0) x -> Tactical e (Sem r0) (Stop Text : r) x) ->
  InterpreterFor (Scoped s e !! Text) r
interpretWithGtk :: (forall (r0 :: EffectRow) x.
 s -> e (Sem r0) x -> Tactical e (Sem r0) (Stop Text : r) x)
-> InterpreterFor (Scoped s e !! Text) r
interpretWithGtk =
  (forall x. (s -> Sem (Stop Text : r) x) -> Sem (Stop Text : r) x)
-> (forall (r0 :: EffectRow) x.
    s -> e (Sem r0) x -> Tactical e (Sem r0) (Stop Text : r) x)
-> InterpreterFor (Scoped s e !! Text) r
forall resource (effect :: (* -> *) -> * -> *) err
       (r :: EffectRow).
(forall x.
 (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x)
-> (forall (r0 :: EffectRow) x.
    resource
    -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x)
-> InterpreterFor (Scoped resource effect !! err) r
interpretScopedResumableH ((s -> Sem (Stop Text : r) x)
-> Sem (Stop Text : r) s -> Sem (Stop Text : r) x
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem (Stop Text : r) s
forall s (r :: EffectRow).
Members '[GtkMain s, Log, Stop Text] r =>
Sem r s
gtkResource)