diff --git a/src/Quasar/Wayland/Connection.hs b/src/Quasar/Wayland/Connection.hs index 5246d68d92247fe62b2e7763e24d7afc4cf2b1ea..3baae689b4356f535d46d343287121a2ac5cca88 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 6cb097b157c03a127fca1bd85e5964f4cdb4d201..496545617dcc0cac7e5842e06f3d251e8c3a912c 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 08d96465c9224b90e8dfe3330121df37a5b3c57e..14fbc6e883f79fac7d860034988b52e28633976b 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 {