mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Minor refactors and fix use of deprecated functions in gui/Main.hs.
This commit is contained in:
parent
73abde9869
commit
bf9434f5e0
71
gui/Main.hs
71
gui/Main.hs
@ -10,26 +10,26 @@
|
|||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad (when)
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Control.Monad.Trans.Reader (runReaderT)
|
import Control.Monad.Trans.Reader (runReaderT)
|
||||||
import Data.Coerce
|
import Data.Coerce (Coercible)
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Data.GI.Base
|
import Data.GI.Base (AttrOp ((:=)), get, new, on, withManagedPtr)
|
||||||
import Data.IORef
|
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
|
||||||
import qualified Data.IntMap.Strict as IntMap
|
import qualified Data.IntMap.Strict as IntMap
|
||||||
import Data.List
|
-- import qualified GI.GdkPixbuf as GP
|
||||||
|
import Data.List (find)
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Data.Time.Clock.System
|
import Data.Time.Clock.System (SystemTime (MkSystemTime), getSystemTime)
|
||||||
import Foreign.Ptr (castPtr)
|
import Foreign.Ptr (castPtr)
|
||||||
import GHC.Word (Word32)
|
import GHC.Word (Word32)
|
||||||
import qualified GI.Cairo
|
import qualified GI.Cairo (Context (..))
|
||||||
import qualified GI.GLib as GLib
|
import qualified GI.GLib as GLib
|
||||||
import qualified GI.Gdk as Gdk
|
import qualified GI.Gdk as Gdk
|
||||||
-- import qualified GI.GdkPixbuf as GP
|
|
||||||
import qualified GI.Gio as Gio
|
import qualified GI.Gio as Gio
|
||||||
import qualified GI.Gtk as Gtk
|
import qualified GI.Gtk as Gtk
|
||||||
import Graphics.Rendering.Cairo
|
import qualified Graphics.Rendering.Cairo as Cairo
|
||||||
import Graphics.Rendering.Cairo.Internal (Render (runRender))
|
import Graphics.Rendering.Cairo.Internal (Render (runRender))
|
||||||
import Graphics.Rendering.Cairo.Types (Cairo (Cairo))
|
import Graphics.Rendering.Cairo.Types (Cairo (Cairo))
|
||||||
|
|
||||||
@ -97,7 +97,8 @@ emptyInputs =
|
|||||||
_inEvents = mempty
|
_inEvents = mempty
|
||||||
}
|
}
|
||||||
|
|
||||||
renderCairo :: Coercible a (ManagedPtr ()) => a -> Render c -> IO c
|
renderCairo :: Coercible a (GI.Cairo.Context) => a -> Render c -> IO c
|
||||||
|
-- renderCairo :: Coercible a (ManagedPtr ()) => a -> Render c -> IO c
|
||||||
renderCairo c r = withManagedPtr c $ \pointer ->
|
renderCairo c r = withManagedPtr c $ \pointer ->
|
||||||
runReaderT (runRender r) (Cairo (castPtr pointer))
|
runReaderT (runRender r) (Cairo (castPtr pointer))
|
||||||
|
|
||||||
@ -110,22 +111,22 @@ getXandY event =
|
|||||||
|
|
||||||
_drawLine :: (Double, Double) -> (Double, Double) -> Render ()
|
_drawLine :: (Double, Double) -> (Double, Double) -> Render ()
|
||||||
_drawLine (fromX, fromY) (toX, toY) = do
|
_drawLine (fromX, fromY) (toX, toY) = do
|
||||||
setSourceRGB 0 1 0
|
Cairo.setSourceRGB 0 1 0
|
||||||
setLineWidth 5
|
Cairo.setLineWidth 5
|
||||||
|
|
||||||
moveTo fromX fromY
|
Cairo.moveTo fromX fromY
|
||||||
lineTo toX toY
|
Cairo.lineTo toX toY
|
||||||
stroke
|
Cairo.stroke
|
||||||
|
|
||||||
_drawCircle :: (Double, Double) -> Render ()
|
_drawCircle :: (Double, Double) -> Render ()
|
||||||
_drawCircle (x, y) = do
|
_drawCircle (x, y) = do
|
||||||
-- setSourceRGB 1 0 0
|
-- setSourceRGB 1 0 0
|
||||||
setLineWidth 1
|
Cairo.setLineWidth 1
|
||||||
-- moveTo x y
|
-- moveTo x y
|
||||||
let radius = 20
|
let radius = 20
|
||||||
let tau = 2 * pi
|
let tau = 2 * pi
|
||||||
arc x y radius 0 tau
|
Cairo.arc x y radius 0 tau
|
||||||
stroke
|
Cairo.stroke
|
||||||
|
|
||||||
drawNode :: (Int, Element) -> Render ()
|
drawNode :: (Int, Element) -> Render ()
|
||||||
drawNode (elemId, Element {..}) = do
|
drawNode (elemId, Element {..}) = do
|
||||||
@ -133,14 +134,14 @@ drawNode (elemId, Element {..}) = do
|
|||||||
(width, height) = _elSize
|
(width, height) = _elSize
|
||||||
halfWidth = width / 2
|
halfWidth = width / 2
|
||||||
|
|
||||||
setSourceRGB 1 0 0
|
Cairo.setSourceRGB 1 0 0
|
||||||
setLineWidth 1
|
Cairo.setLineWidth 1
|
||||||
rectangle x y halfWidth height
|
Cairo.rectangle x y halfWidth height
|
||||||
showText (show elemId)
|
Cairo.showText (show elemId)
|
||||||
stroke
|
Cairo.stroke
|
||||||
setSourceRGB 0 1 0
|
Cairo.setSourceRGB 0 1 0
|
||||||
rectangle (x + halfWidth) y halfWidth height
|
Cairo.rectangle (x + halfWidth) y halfWidth height
|
||||||
stroke
|
Cairo.stroke
|
||||||
|
|
||||||
updateBackground :: p -> IORef AppState -> Render ()
|
updateBackground :: p -> IORef AppState -> Render ()
|
||||||
updateBackground _canvas stateRef = do
|
updateBackground _canvas stateRef = do
|
||||||
@ -150,14 +151,14 @@ updateBackground _canvas stateRef = do
|
|||||||
-- :: Render Double)
|
-- :: Render Double)
|
||||||
|
|
||||||
-- TODO This should be moved into the setup phase
|
-- TODO This should be moved into the setup phase
|
||||||
setSourceRGB 0 0 0
|
Cairo.setSourceRGB 0 0 0
|
||||||
paint
|
Cairo.paint
|
||||||
|
|
||||||
stateVal <- liftIO $ readIORef stateRef
|
stateVal <- Cairo.liftIO $ readIORef stateRef
|
||||||
setSourceRGB 1 1 1
|
Cairo.setSourceRGB 1 1 1
|
||||||
moveTo 10 10
|
Cairo.moveTo 10 10
|
||||||
showText ("fps=" <> show (_asFPSr stateVal))
|
Cairo.showText ("fps=" <> show (_asFPSr stateVal))
|
||||||
setSourceRGB 1 0 0
|
Cairo.setSourceRGB 1 0 0
|
||||||
traverse_ drawNode (IntMap.toList (_asElements stateVal))
|
traverse_ drawNode (IntMap.toList (_asElements stateVal))
|
||||||
|
|
||||||
findElementByPosition ::
|
findElementByPosition ::
|
||||||
@ -313,8 +314,8 @@ startApp app = do
|
|||||||
#showAll window
|
#showAll window
|
||||||
gdkWindow <- fromJust <$> #getWindow window
|
gdkWindow <- fromJust <$> #getWindow window
|
||||||
display <- fmap fromJust Gdk.displayGetDefault -- TODO unsafe
|
display <- fmap fromJust Gdk.displayGetDefault -- TODO unsafe
|
||||||
deviceManager <- fromJust <$> Gdk.displayGetDeviceManager display -- TODO deprecated
|
seat <- Gdk.displayGetDefaultSeat display
|
||||||
device <- Gdk.deviceManagerGetClientPointer deviceManager
|
device <- fromJust <$> Gdk.seatGetPointer seat -- TODO unsafe
|
||||||
_ <-
|
_ <-
|
||||||
GLib.timeoutAdd
|
GLib.timeoutAdd
|
||||||
GLib.PRIORITY_DEFAULT
|
GLib.PRIORITY_DEFAULT
|
||||||
|
Loading…
Reference in New Issue
Block a user