{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase, OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Moffy.Samples.Run.Gtk3 (runSingleWin) where

import Control.Monad
import Control.Monad.ST
import Control.Concurrent
import Control.Concurrent.STM
import Data.Type.Set
import Data.OneOrMore qualified as OOM
import Data.OneOrMoreApp
import Data.Bits
import Data.Maybe
import Data.Text qualified as T
import Data.Color
import System.Environment

import Control.Moffy
import Control.Moffy.Samples.Event.Delete
import Control.Moffy.Samples.Event.Mouse qualified as Mouse
import Control.Moffy.Samples.Event.CalcTextExtents
import Control.Moffy.Samples.View

import Data.CairoContext
import Graphics.Cairo.Drawing.CairoT
import Graphics.Cairo.Drawing.Paths
import Graphics.Cairo.Drawing.Transformations
import Graphics.Cairo.Surfaces.ImageSurfaces
import Graphics.Cairo.Surfaces.PngSupport

import Graphics.Pango.Basic.LayoutObjects.PangoLayout
import Graphics.Pango.Basic.Fonts.PangoFontDescription
import Graphics.Pango.Basic.GlyphStorage
import Graphics.Pango.Rendering.Cairo

import Stopgap.Data.Ptr
import Stopgap.System.GLib qualified as G
import Stopgap.System.GLib.Signal qualified as G.Signal
import Stopgap.Graphics.UI.Gtk qualified as Gtk
import Stopgap.Graphics.UI.Gtk.Widget qualified as Gtk.Widget
import Stopgap.Graphics.UI.Gtk.Container qualified as Gtk.Container
import Stopgap.Graphics.UI.Gtk.Window qualified as Gtk.Window
import Stopgap.Graphics.UI.Gtk.DrawingArea qualified as Gtk.DrawingArea
import Stopgap.Graphics.UI.Gdk.Event qualified as Gdk.Event
import Stopgap.Graphics.UI.Gdk.Event.Button qualified as Gdk.Event.Button
import Stopgap.Graphics.UI.Gdk.Event.Motion qualified as Gdk.Event.Motion
import Stopgap.Graphics.UI.Gdk.Window qualified as Gdk.Window

type Events = CalcTextExtents :-
	Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent

clicked :: TChan (EvOccs Events) ->
	Gtk.DrawingArea.D -> Gdk.Event.Button.B -> ud -> IO Bool
clicked :: forall ud. TChan (EvOccs Events) -> D -> B -> ud -> IO Bool
clicked TChan (EvOccs Events)
ceo D
_da B
eb ud
_ud = do
	case B -> Type
Gdk.Event.Button.bType B
eb of
		Type
Gdk.Event.ButtonPress -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (OneOrMoreApp
      ('SetApp
         Occurred
         (Occurred Move
          ':~ (Occurred Down
               ':~ (Occurred Up
                    ':~ (Occurred CalcTextExtents
                         ':~ (Occurred DeleteEvent ':~ 'Nil))))))
    -> STM ())
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (EvOccs Events)
TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
ceo
			(OneOrMoreApp
   ('SetApp
      Occurred
      (Occurred Move
       ':~ (Occurred Down
            ':~ (Occurred Up
                 ':~ (Occurred CalcTextExtents
                      ':~ (Occurred DeleteEvent ':~ 'Nil))))))
 -> IO ())
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ OneOrMoreApp
  ('SetApp Occurred (Occurred Move ':~ (Occurred Down ':~ 'Nil)))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
forall (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Expandable as as' =>
OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
expand (Point -> Occurred Move
Mouse.OccMove (B -> Point
mousePoint B
eb) Occurred Move
-> OneOrMoreApp ('SetApp Occurred (Occurred Down ':~ 'Nil))
-> OneOrMoreApp
     ('SetApp Occurred (Occurred Move ':~ (Occurred Down ':~ 'Nil)))
forall a (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Insertable a as as' =>
a -> OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
>- Occurred Down
-> OneOrMoreApp ('SetApp Occurred (Occurred Down ':~ 'Nil))
forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton (Button -> Occurred Down
Mouse.OccDown (Button -> Occurred Down) -> Button -> Occurred Down
forall a b. (a -> b) -> a -> b
$ B -> Button
mouseButton B
eb) :: EvOccs (Mouse.Move :- Singleton Mouse.Down))
		Type
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
	Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

released :: TChan (EvOccs Events) ->
	Gtk.DrawingArea.D -> Gdk.Event.Button.B -> ud -> IO Bool
released :: forall ud. TChan (EvOccs Events) -> D -> B -> ud -> IO Bool
released TChan (EvOccs Events)
ceo D
_da B
eb ud
_ud = do
	case B -> Type
Gdk.Event.Button.bType B
eb of
		Type
Gdk.Event.ButtonRelease -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (OneOrMoreApp
      ('SetApp
         Occurred
         (Occurred Move
          ':~ (Occurred Down
               ':~ (Occurred Up
                    ':~ (Occurred CalcTextExtents
                         ':~ (Occurred DeleteEvent ':~ 'Nil))))))
    -> STM ())
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (EvOccs Events)
TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
ceo
			(OneOrMoreApp
   ('SetApp
      Occurred
      (Occurred Move
       ':~ (Occurred Down
            ':~ (Occurred Up
                 ':~ (Occurred CalcTextExtents
                      ':~ (Occurred DeleteEvent ':~ 'Nil))))))
 -> IO ())
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> IO ()
forall a b. (a -> b) -> a -> b
$ OneOrMoreApp
  ('SetApp Occurred (Occurred Move ':~ (Occurred Up ':~ 'Nil)))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
forall (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Expandable as as' =>
OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
expand (Point -> Occurred Move
Mouse.OccMove (B -> Point
mousePoint B
eb) Occurred Move
-> OneOrMoreApp ('SetApp Occurred (Occurred Up ':~ 'Nil))
-> OneOrMoreApp
     ('SetApp Occurred (Occurred Move ':~ (Occurred Up ':~ 'Nil)))
forall a (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Insertable a as as' =>
a -> OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
>- Occurred Up
-> OneOrMoreApp ('SetApp Occurred (Occurred Up ':~ 'Nil))
forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton (Button -> Occurred Up
Mouse.OccUp (Button -> Occurred Up) -> Button -> Occurred Up
forall a b. (a -> b) -> a -> b
$ B -> Button
mouseButton B
eb) :: EvOccs (Mouse.Move :- Singleton Mouse.Up))
		Type
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
	Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

moved :: TChan (EvOccs Events) ->
	Gtk.DrawingArea.D -> Gdk.Event.Motion.M -> ud -> IO Bool
moved :: forall ud. TChan (EvOccs Events) -> D -> M -> ud -> IO Bool
moved TChan (EvOccs Events)
ceo D
_da M
em ud
_ud = do
	STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Point -> STM ()) -> Point -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
-> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (EvOccs Events)
TChan
  (OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
ceo (OneOrMoreApp
   ('SetApp
      Occurred
      (Occurred Move
       ':~ (Occurred Down
            ':~ (Occurred Up
                 ':~ (Occurred CalcTextExtents
                      ':~ (Occurred DeleteEvent ':~ 'Nil))))))
 -> STM ())
-> (Point
    -> OneOrMoreApp
         ('SetApp
            Occurred
            (Occurred Move
             ':~ (Occurred Down
                  ':~ (Occurred Up
                       ':~ (Occurred CalcTextExtents
                            ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
-> Point
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move)))
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
forall (as :: Set (*)) (as' :: Set (*)) (f :: * -> *).
Expandable as as' =>
OneOrMoreApp ('SetApp f as) -> OneOrMoreApp ('SetApp f as')
expand (OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move)))
 -> OneOrMoreApp
      ('SetApp
         Occurred
         (Occurred Move
          ':~ (Occurred Down
               ':~ (Occurred Up
                    ':~ (Occurred CalcTextExtents
                         ':~ (Occurred DeleteEvent ':~ 'Nil)))))))
-> (Point
    -> OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move))))
-> Point
-> OneOrMoreApp
     ('SetApp
        Occurred
        (Occurred Move
         ':~ (Occurred Down
              ':~ (Occurred Up
                   ':~ (Occurred CalcTextExtents
                        ':~ (Occurred DeleteEvent ':~ 'Nil))))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Occurred Move
-> OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move)))
forall a (f :: * -> *). a -> OneOrMoreApp ('SetApp f (Singleton a))
Singleton (Occurred Move
 -> OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move))))
-> (Point -> Occurred Move)
-> Point
-> OneOrMoreApp ('SetApp Occurred (Singleton (Occurred Move)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Occurred Move
Mouse.OccMove (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ M -> Point
movePoint M
em
	Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

mouseButton :: Gdk.Event.Button.B -> Mouse.Button
mouseButton :: B -> Button
mouseButton B
eb = case B -> Word32
Gdk.Event.Button.bButton B
eb of
	Word32
1 -> Button
Mouse.ButtonPrimary
	Word32
2 -> Button
Mouse.ButtonMiddle
	Word32
3 -> Button
Mouse.ButtonSecondary
	Word32
_ -> Button
Mouse.ButtonMiddle

mousePoint :: Gdk.Event.Button.B -> Point
mousePoint :: B -> Point
mousePoint B
eb = (B -> Double
Gdk.Event.Button.bX B
eb, B -> Double
Gdk.Event.Button.bY B
eb)

movePoint :: Gdk.Event.Motion.M -> Point
movePoint :: M -> Point
movePoint M
em = (M -> Double
Gdk.Event.Motion.mX M
em, M -> Double
Gdk.Event.Motion.mY M
em)

deleteHandle :: a -> b -> IO Bool
deleteHandle :: forall a b. a -> b -> IO Bool
deleteHandle a
x b
y = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

runSingleWin ::
	TChan (EvReqs Events) -> TChan (EvOccs Events) -> TChan View -> IO ()
runSingleWin :: TChan (EvReqs Events)
-> TChan (EvOccs Events) -> TChan View -> IO ()
runSingleWin TChan (EvReqs Events)
cer TChan (EvOccs Events)
ceo TChan View
cv = do
	crd <- STM (TVar [View1]) -> IO (TVar [View1])
forall a. STM a -> IO a
atomically (STM (TVar [View1]) -> IO (TVar [View1]))
-> STM (TVar [View1]) -> IO (TVar [View1])
forall a b. (a -> b) -> a -> b
$ [View1] -> STM (TVar [View1])
forall a. a -> STM (TVar a)
newTVar []
	cte <- atomically newTChan

	join $ Gtk.init <$> getProgName <*> getArgs

	w <- Gtk.Window.new Gtk.Window.Toplevel
	G.Signal.connect_ab_bool w "delete-event" deleteHandle Null
	G.Signal.connect_void_void w "destroy" Gtk.mainQuit Null

	da <- Gtk.DrawingArea.new
	Gtk.Container.add w da
	Gtk.Widget.addEvents da $
		Gdk.Event.ButtonPressMask .|.
		Gdk.Event.ButtonReleaseMask .|.
		Gdk.Event.ButtonMotionMask .|.
		Gdk.Event.PointerMotionMask
	G.Signal.connect_self_button_ud
		da "button-press-event" (clicked ceo) Null
	G.Signal.connect_self_button_ud
		da "button-release-event" (released ceo) Null
	G.Signal.connect_self_motion_ud
		da "motion-notify-event" (moved ceo) Null
	G.Signal.connect_self_cairo_ud da "draw" (drawFunction crd ceo cte) Null

	Gtk.Widget.showAll w

	forkIO . forever $ atomically (readTChan cer) >>= \OneOrMore
  (Move
   ':~ (Down
        ':~ (Up ':~ (CalcTextExtents ':~ (DeleteEvent ':~ 'Nil)))))
r -> do
		case OneOrMore
  (Move
   ':~ (Down
        ':~ (Up ':~ (CalcTextExtents ':~ (DeleteEvent ':~ 'Nil)))))
-> Maybe CalcTextExtents
forall (as :: Set (*)) a.
Projectable as a =>
OneOrMore as -> Maybe a
OOM.project OneOrMore
  (Move
   ':~ (Down
        ':~ (Up ':~ (CalcTextExtents ':~ (DeleteEvent ':~ 'Nil)))))
r of
			Maybe CalcTextExtents
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
			Just (CalcTextExtentsReq FontName
fn Double
fs Text
t) -> do
				STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (FontName, Double, Text)
-> (FontName, Double, Text) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (FontName, Double, Text)
cte (FontName
fn, Double
fs, Text
t)
				IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ()) -> IO Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Null -> IO Bool) -> Null -> IO Word32
forall ud. IsPtr ud => (ud -> IO Bool) -> ud -> IO Word32
G.idleAdd
					(\Null
_ -> D -> IO ()
forall w. IsW w => w -> IO ()
Gtk.Widget.queueDraw D
da IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
						Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
					Null
Null

	forkIO . forever $ atomically (readTChan cv) >>= \case
		View
Stopped -> IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ()) -> IO Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Null -> IO Bool) -> Null -> IO Word32
forall ud. IsPtr ud => (ud -> IO Bool) -> ud -> IO Word32
G.idleAdd
			(\Null
_ -> do
				W -> IO ()
Gtk.Window.close W
w
				W -> IO ()
Gdk.Window.destroy (W -> IO ()) -> IO W -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< W -> IO W
forall w. IsW w => w -> IO W
Gtk.Widget.getWindow W
w
				IO ()
Gtk.mainQuit
				Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
			Null
Null
		View [View1]
v -> do
			STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [View1] -> [View1] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [View1]
crd [View1]
v
			IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ()) -> IO Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Null -> IO Bool) -> Null -> IO Word32
forall ud. IsPtr ud => (ud -> IO Bool) -> ud -> IO Word32
G.idleAdd
				(\Null
_ -> D -> IO ()
forall w. IsW w => w -> IO ()
Gtk.Widget.queueDraw D
da IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
				Null
Null
		View
v -> View -> IO ()
forall a. Show a => a -> IO ()
print View
v

	Gtk.main

drawFunction :: TVar [View1] ->
	TChan (EvOccs Events) -> TChan (FontName, FontSize, T.Text) ->
	Gtk.DrawingArea.D -> CairoT r RealWorld -> Null -> IO Bool
drawFunction :: forall r.
TVar [View1]
-> TChan (EvOccs Events)
-> TChan (FontName, Double, Text)
-> D
-> CairoT r RealWorld
-> Null
-> IO Bool
drawFunction TVar [View1]
crd TChan (EvOccs Events)
ceo TChan (FontName, Double, Text)
cte D
_ CairoT r RealWorld
cr Null
Null = do
	STM (Maybe (FontName, Double, Text))
-> IO (Maybe (FontName, Double, Text))
forall a. STM a -> IO a
atomically (TChan (FontName, Double, Text)
-> STM (Maybe (FontName, Double, Text))
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (FontName, Double, Text)
cte) IO (Maybe (FontName, Double, Text))
-> (Maybe (FontName, Double, Text) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
		Maybe (FontName, Double, Text)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
		Just (FontName
fn, Double
fs, Text
txt) -> TChan (EvOccs Events)
-> CairoT r RealWorld -> FontName -> Double -> Text -> IO ()
forall r.
TChan (EvOccs Events)
-> CairoT r RealWorld -> FontName -> Double -> Text -> IO ()
occCalcTextExtents TChan (EvOccs Events)
ceo CairoT r RealWorld
cr FontName
fn Double
fs Text
txt
	CairoT r (PrimState IO) -> Rgb CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> Rgb CDouble -> m ()
cairoSetSourceRgb CairoT r RealWorld
CairoT r (PrimState IO)
cr (Rgb CDouble -> IO ())
-> (Maybe (Rgb CDouble) -> Rgb CDouble)
-> Maybe (Rgb CDouble)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Rgb CDouble) -> Rgb CDouble
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Rgb CDouble) -> IO ()) -> Maybe (Rgb CDouble) -> IO ()
forall a b. (a -> b) -> a -> b
$ CDouble -> CDouble -> CDouble -> Maybe (Rgb CDouble)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble CDouble
0.5 CDouble
0.5 CDouble
0.5
	CairoT r (PrimState IO) -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> m ()
cairoPaint CairoT r RealWorld
CairoT r (PrimState IO)
cr
	(CairoT r RealWorld -> View1 -> IO ()
forall r. CairoT r RealWorld -> View1 -> IO ()
drawView1 CairoT r RealWorld
cr (View1 -> IO ()) -> [View1] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_`) ([View1] -> IO ()) -> IO [View1] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM [View1] -> IO [View1]
forall a. STM a -> IO a
atomically (TVar [View1] -> STM [View1]
forall a. TVar a -> STM a
readTVar TVar [View1]
crd)
	Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

drawView1 :: CairoT r RealWorld -> View1 -> IO ()
drawView1 :: forall r. CairoT r RealWorld -> View1 -> IO ()
drawView1 CairoT r RealWorld
cr (Box
	(Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
l, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
u)
	(Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
r, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
d)
	(Rgb Double -> Rgb CDouble
forall d d'. (Real d, Fractional d') => Rgb d -> Rgb d'
rgbRealToFrac -> Rgb CDouble
clr)) = do
	CairoT r (PrimState IO) -> Rgb CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> Rgb CDouble -> m ()
cairoSetSourceRgb CairoT r RealWorld
CairoT r (PrimState IO)
cr Rgb CDouble
clr
	CairoT r (PrimState IO)
-> CDouble -> CDouble -> CDouble -> CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m)
-> CDouble -> CDouble -> CDouble -> CDouble -> m ()
cairoRectangle CairoT r RealWorld
CairoT r (PrimState IO)
cr CDouble
l CDouble
u (CDouble
r CDouble -> CDouble -> CDouble
forall a. Num a => a -> a -> a
- CDouble
l) (CDouble
d CDouble -> CDouble -> CDouble
forall a. Num a => a -> a -> a
- CDouble
u)
	CairoT r (PrimState IO) -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> m ()
cairoFill CairoT r RealWorld
CairoT r (PrimState IO)
cr
drawView1 CairoT r RealWorld
cr (VLine (Rgb Double -> Rgb CDouble
forall d d'. (Real d, Fractional d') => Rgb d -> Rgb d'
rgbRealToFrac -> Rgb CDouble
clr) Double
lw
	(Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
l, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
u)
	(Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
r, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
d)) = do
	CairoT r (PrimState IO) -> Rgb CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> Rgb CDouble -> m ()
cairoSetSourceRgb CairoT r RealWorld
CairoT r (PrimState IO)
cr Rgb CDouble
clr
	CairoT r (PrimState IO) -> CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> CDouble -> m ()
cairoSetLineWidth CairoT r RealWorld
CairoT r (PrimState IO)
cr (CDouble -> IO ()) -> CDouble -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
lw
	CairoT r (PrimState IO) -> CDouble -> CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> CDouble -> CDouble -> m ()
cairoMoveTo CairoT r RealWorld
CairoT r (PrimState IO)
cr CDouble
l CDouble
u
	CairoT r (PrimState IO) -> CDouble -> CDouble -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> CDouble -> CDouble -> m ()
cairoLineTo CairoT r RealWorld
CairoT r (PrimState IO)
cr CDouble
r CDouble
d
	CairoT r (PrimState IO) -> IO ()
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> m ()
cairoStroke CairoT r RealWorld
CairoT r (PrimState IO)
cr
drawView1 CairoT r RealWorld
cr (VText (Rgb Double -> Rgb CDouble
forall d d'. (Real d, Fractional d') => Rgb d -> Rgb d'
rgbRealToFrac -> Rgb CDouble
clr)
	FontName
fn (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
fs) (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
x, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
y) Text
txt) = do
	(l, d) <- (,) (PangoLayoutPrim RealWorld
 -> PangoFontDescriptionPrim RealWorld
 -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
-> IO (PangoLayoutPrim RealWorld)
-> IO
     (PangoFontDescriptionPrim RealWorld
      -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CairoT r (PrimState IO) -> IO (PangoLayoutPrim (PrimState IO))
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> m (PangoLayoutPrim (PrimState m))
pangoCairoCreateLayout CairoT r RealWorld
CairoT r (PrimState IO)
cr IO
  (PangoFontDescriptionPrim RealWorld
   -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
-> IO (PangoFontDescriptionPrim RealWorld)
-> IO
     (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (PangoFontDescriptionPrim RealWorld)
IO (PangoFontDescriptionPrim (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
m (PangoFontDescriptionPrim (PrimState m))
pangoFontDescriptionNew
	d `pangoFontDescriptionSet` Family fn
	d `pangoFontDescriptionSet` AbsoluteSize fs
	d' <- pangoFontDescriptionFreeze d
	l `pangoLayoutSet` pangoFontDescriptionToNullable (Just d')
	l `pangoLayoutSet` txt
	l' <- pangoLayoutFreeze l
	cairoMoveTo cr x y
	cairoSetSourceRgb cr clr
	pangoCairoShowLayout cr l'
drawView1 CairoT r RealWorld
cr (VImage
	(Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
x, Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
y) Double
w Double
h ByteString
dt) = do
	sfc <- ByteString -> IO (CairoSurfaceImageT Any (PrimState IO))
forall (m :: * -> *) s.
PrimMonad m =>
ByteString -> m (CairoSurfaceImageT s (PrimState m))
cairoSurfaceCreateFromPngByteString ByteString
dt
	w0 <- cairoImageSurfaceGetWidth sfc
	h0 <- cairoImageSurfaceGetHeight sfc
	cairoTranslate cr x y
	cairoScale cr
		(realToFrac w / fromIntegral w0)
		(realToFrac h / fromIntegral h0)
	cairoSetSourceSurface cr sfc 0 0
	cairoPaint cr

	cairoIdentityMatrix cr
drawView1 CairoT r RealWorld
cr View1
NotImplemented = FontName -> IO ()
putStrLn FontName
"NOT IMPLEMENTED"

occCalcTextExtents ::
	TChan (EvOccs (CalcTextExtents :- GuiEv)) -> CairoT r RealWorld -> String -> Double -> T.Text -> IO ()
occCalcTextExtents :: forall r.
TChan (EvOccs Events)
-> CairoT r RealWorld -> FontName -> Double -> Text -> IO ()
occCalcTextExtents TChan (EvOccs Events)
co CairoT r RealWorld
cr FontName
fn Double
fs Text
txt = do
	(l, d) <- (,) (PangoLayoutPrim RealWorld
 -> PangoFontDescriptionPrim RealWorld
 -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
-> IO (PangoLayoutPrim RealWorld)
-> IO
     (PangoFontDescriptionPrim RealWorld
      -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CairoT r (PrimState IO) -> IO (PangoLayoutPrim (PrimState IO))
forall (m :: * -> *) r.
PrimMonad m =>
CairoT r (PrimState m) -> m (PangoLayoutPrim (PrimState m))
pangoCairoCreateLayout CairoT r RealWorld
CairoT r (PrimState IO)
cr IO
  (PangoFontDescriptionPrim RealWorld
   -> (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld))
-> IO (PangoFontDescriptionPrim RealWorld)
-> IO
     (PangoLayoutPrim RealWorld, PangoFontDescriptionPrim RealWorld)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (PangoFontDescriptionPrim RealWorld)
IO (PangoFontDescriptionPrim (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
m (PangoFontDescriptionPrim (PrimState m))
pangoFontDescriptionNew
	d `pangoFontDescriptionSet` Family fn
	d `pangoFontDescriptionSet` AbsoluteSize (realToFrac fs)
	d' <- pangoFontDescriptionFreeze d
	l `pangoLayoutSet` pangoFontDescriptionToNullable (Just d')
	l `pangoLayoutSet` txt
	l' <- pangoLayoutFreeze l
	let	PixelExtents ie le = pangoLayoutInfo l'
	atomically . writeTChan co . expand . Singleton
		. OccCalcTextExtents fn fs txt
		$ mkte ie le
	where
	mkte :: PangoRectanglePixel -> PangoRectanglePixel -> TextExtents
mkte PangoRectanglePixel
ie PangoRectanglePixel
le = Rectangle -> Rectangle -> TextExtents
TextExtents (PangoRectanglePixel -> Rectangle
r2r PangoRectanglePixel
ie) (PangoRectanglePixel -> Rectangle
r2r PangoRectanglePixel
le)
	r2r :: PangoRectanglePixel -> Rectangle
r2r PangoRectanglePixel
r = CInt -> CInt -> CInt -> CInt -> Rectangle
forall {a} {a} {a} {a}.
(Integral a, Integral a, Integral a, Integral a) =>
a -> a -> a -> a -> Rectangle
rct
		(PangoRectanglePixel -> CInt
pangoRectanglePixelX PangoRectanglePixel
r) (PangoRectanglePixel -> CInt
pangoRectanglePixelY PangoRectanglePixel
r)
		(PangoRectanglePixel -> CInt
pangoRectanglePixelWidth PangoRectanglePixel
r) (PangoRectanglePixel -> CInt
pangoRectanglePixelHeight PangoRectanglePixel
r)
	rct :: a -> a -> a -> a -> Rectangle
rct	(a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Double
l) (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Double
t)
		(a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Double
w) (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Double
h) = Double -> Double -> Double -> Double -> Rectangle
Rectangle Double
l Double
t Double
w Double
h

type GuiEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent