{-# options_haddock prune #-}

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

import Conc (Lock, interpretLockReentrant, interpretSync, lock)
import Polysemy.Opaque (Opaque)
import qualified 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
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
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
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
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 { forall s. GtkResource s -> s
unGtkResource :: s }
  deriving stock (GtkResource s -> GtkResource s -> Bool
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
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, Lock, Sync StartGtkMain, Sync (GtkResource s)] r =>
  wait ->
  restart ->
  GtkMain s m a ->
  Tactical e m r a
handleGtkMain :: forall s wait restart (e :: Effect) (m :: * -> *) (r :: EffectRow)
       a.
(TimeUnit wait, TimeUnit restart,
 Members
   '[Resource, Lock, Sync StartGtkMain, Sync (GtkResource s)] r) =>
wait -> restart -> GtkMain s m a -> Tactical e m r a
handleGtkMain wait
wait restart
restart = \case
  GtkMain.Access m s
ms -> do
    forall (r :: EffectRow) a. Member Lock r => Sem r a -> Sem r a
lock do
      forall d (r :: EffectRow). Member (Sync d) r => Sem r (Maybe d)
Sync.try forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (GtkResource a
s) ->
          forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
s
        Maybe (GtkResource a)
Nothing ->
          forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m s
ms
  GtkMain.Request m s
ms -> do
    forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
    forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r Bool
Sync.putTry StartGtkMain
StartGtkMain
    forall d (r :: EffectRow) u.
(Member (Sync d) r, TimeUnit u) =>
u -> Sem r (Maybe d)
Sync.wait wait
wait forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just (GtkResource a
s) ->
        forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT a
s
      Maybe (GtkResource a)
Nothing ->
        forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m s
ms
  GtkMain.Run m a
ma -> do
    forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @StartGtkMain
    forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
    forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple m a
ma forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* do
      forall a (r :: EffectRow). Member (Sync a) r => Sem r ()
Sync.clear @(GtkResource _)
      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 ->
    forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r ()
Sync.putBlock (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 [Mask, Resource, Race, Embed IO] r =>
  wait ->
  restart ->
  InterpreterFor (GtkMain s) r
interpretGtkMain :: forall s wait restart (r :: EffectRow).
(TimeUnit wait, TimeUnit restart,
 Members '[Mask, Resource, Race, Embed IO] r) =>
wait -> restart -> InterpreterFor (GtkMain s) r
interpretGtkMain wait
wait restart
restart =
  forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync d) r
interpretSync forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (r :: EffectRow).
Members '[Resource, Race, Mask, Embed IO] r =>
InterpreterFor Lock r
interpretLockReentrant forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync d) r
interpretSync @StartGtkMain forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (e :: Effect) (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 (forall s wait restart (e :: Effect) (m :: * -> *) (r :: EffectRow)
       a.
(TimeUnit wait, TimeUnit restart,
 Members
   '[Resource, Lock, Sync StartGtkMain, Sync (GtkResource s)] r) =>
wait -> restart -> GtkMain s m a -> Tactical e m r a
handleGtkMain wait
wait restart
restart) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (e2 :: Effect) (e3 :: Effect) (e4 :: Effect) (e1 :: Effect)
       (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 =>
  (∀ q r0 x . s -> e (Sem r0) x -> Tactical e (Sem r0) (Stop Text : Opaque q : r) x) ->
  InterpreterFor (Scoped_ e !! Text) r
interpretWithGtk :: forall (e :: Effect) s (r :: EffectRow).
Members '[GtkMain s, Log] r =>
(forall (q :: Effect) (r0 :: EffectRow) x.
 s
 -> e (Sem r0) x
 -> Tactical e (Sem r0) (Stop Text : Opaque q : r) x)
-> InterpreterFor (Scoped_ e !! Text) r
interpretWithGtk =
  forall param resource (effect :: Effect) err (r :: EffectRow).
(forall (q :: Effect) x.
 param
 -> (resource -> Sem (Stop err : Opaque q : r) x)
 -> Sem (Stop err : Opaque q : r) x)
-> (forall (q :: Effect) (r0 :: EffectRow) x.
    resource
    -> effect (Sem r0) x
    -> Tactical effect (Sem r0) (Stop err : Opaque q : r) x)
-> InterpreterFor (Scoped param effect !! err) r
interpretScopedResumableH \ () -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (r :: EffectRow).
Members '[GtkMain s, Log, Stop Text] r =>
Sem r s
gtkResource)