From 113c4c72a70fae82edd71f95e133d424db6d3c65 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 16 Sep 2021 21:52:28 +0200
Subject: [PATCH] Fix warnings
---
src/Quasar/Wayland/Connection.hs | 5 +++--
src/Quasar/Wayland/Protocol/Core.hs | 11 ++++-------
src/Quasar/Wayland/Protocol/TH.hs | 21 ++++++++++-----------
3 files changed, 17 insertions(+), 20 deletions(-)
diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs
index 5246d68..3baae68 100644
--- a/src/Quasar/Wayland/Connection.hs
+++ b/src/Quasar/Wayland/Connection.hs
@@ -58,10 +58,11 @@ newWaylandConnection initializeProtocolAction socket = do
pure (result, connection)
connectionThread :: MonadAsync m => WaylandConnection s -> IO () -> m ()
-connectionThread connection work = async_ $ liftIO $ work `catches` [ignoreCancelTask, handleAll]
+connectionThread connection work = async_ $ liftIO $ work `catches` [ignoreCancelTask, traceAndDisposeConnection]
where
+ ignoreCancelTask :: Handler IO a
ignoreCancelTask = Handler (throwM :: CancelTask -> IO a)
- handleAll = Handler (\(ex :: SomeException) -> traceIO (displayException ex) >> void (dispose connection))
+ traceAndDisposeConnection = Handler (\(ex :: SomeException) -> traceIO (displayException ex) >> void (dispose connection))
sendThread :: WaylandConnection s -> IO ()
sendThread connection = forever do
diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 6cb097b..4965456 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -54,8 +54,7 @@ module Quasar.Wayland.Protocol.Core (
import Control.Concurrent.STM
import Control.Monad (replicateM_)
import Control.Monad.Catch
-import Control.Monad.Reader (ReaderT, runReaderT, ask, asks, lift)
-import Control.Monad.State qualified as State
+import Control.Monad.Reader (ReaderT, runReaderT, ask, lift)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
@@ -65,7 +64,6 @@ import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
-import Data.Maybe (isJust)
import Data.Proxy
import Data.Void (absurd)
import GHC.TypeLits
@@ -418,11 +416,11 @@ initializeProtocol wlDisplayCallback initializationAction = do
nextIdVar
}
stateVar <- newTVar (Right state)
- let handle = ProtocolHandle {
+ let protocol = ProtocolHandle {
stateVar
}
result <- runReaderT (initializationAction wlDisplay) state
- pure (result, handle)
+ pure (result, protocol)
where
wlDisplay :: Object s wl_display
wlDisplay = Object 1 wlDisplayCallback
@@ -438,8 +436,7 @@ runProtocolM (ProtocolHandle stateVar) action = do
Left ex -> throwM ex
Right state -> do
-- Run action, catch exceptions
- result <- runReaderT (try action) state
- case result of
+ runReaderT (try action) state >>= \case
Left ex -> do
-- Action failed, change protocol state to failed
writeTVar stateVar (Left ex)
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 08d9646..14fbc6e 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -2,15 +2,14 @@ module Quasar.Wayland.Protocol.TH (
generateWaylandProcol
) where
-import Control.Monad.Catch
import Control.Monad.Writer
-import Data.Binary
import Data.ByteString qualified as BS
import Language.Haskell.TH
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Syntax (BangType, VarBangType, addDependentFile)
+--import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax (BangType, addDependentFile)
import Language.Haskell.TH.Syntax qualified as TH
import Data.List (intersperse)
+import Prelude qualified
import Quasar.Prelude
import Quasar.Wayland.Protocol.Core
import Text.XML.Light
@@ -324,7 +323,7 @@ parseProtocol xml = do
parseInterface :: MonadFail m => Element -> m InterfaceSpec
parseInterface element = do
name <- getAttr "name" element
- version <- read <$> getAttr "version" element
+ version <- Prelude.read <$> getAttr "version" element
requests <- mapM (parseRequest name) $ zip [0..] $ findChildren (qname "request") element
events <- mapM (parseEvent name) $ zip [0..] $ findChildren (qname "event") element
pure InterfaceSpec {
@@ -341,15 +340,15 @@ parseEvent :: MonadFail m => String -> (Opcode, Element) -> m EventSpec
parseEvent x y = EventSpec <$> parseMessage False x y
parseMessage :: MonadFail m => Bool -> String -> (Opcode, Element) -> m MessageSpec
-parseMessage isRequest interfaceName (opcode, element) = do
+parseMessage isRequest interface (opcode, element) = do
let isEvent = not isRequest
name <- getAttr "name" element
- let description = interfaceName <> "." <> name
+ let description = interface <> "." <> name
mtype <- peekAttr "type" element
- since <- read <<$>> peekAttr "since" element
+ since <- Prelude.read <<$>> peekAttr "since" element
arguments <- mapM (parseArgument description) $ zip [0..] $ findChildren (qname "arg") element
isDestructor <-
@@ -363,15 +362,15 @@ parseMessage isRequest interfaceName (opcode, element) = do
do fail $ "Event cannot be a destructor: " <> description
when
- do (foldr (\arg -> if isNewId arg.argType then (+ 1) else id) 0 arguments) > 1
+ do (foldr (\arg -> if isNewId arg.argType then (+ 1) else id) 0 arguments) > (1 :: Int)
do fail $ "Message creates multiple objects: " <> description
forM_ arguments \arg -> do
when
- do arg.argType == GenericNewIdArgument && (interfaceName /= "wl_registry" || name /= "bind")
+ do arg.argType == GenericNewIdArgument && (interface /= "wl_registry" || name /= "bind")
do fail $ "Invalid \"new_id\" argument without \"interface\" attribute encountered on " <> description <> " (only valid on wl_registry.bind)"
when
- do arg.argType == GenericObjectArgument && (interfaceName /= "wl_display" || name /= "error")
+ do arg.argType == GenericObjectArgument && (interface /= "wl_display" || name /= "error")
do fail $ "Invalid \"object\" argument without \"interface\" attribute encountered on " <> description <> " (only valid on wl_display.error)"
pure MessageSpec {
--
GitLab