diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index b1e8dfbb8841dab9b484c15d123fa3fdb1dd8fd2..509cf030709eb2e8bdbe8bb72149ae141a764812 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -56,11 +56,8 @@ module Quasar.Wayland.Protocol.Core ( ) where import Control.Concurrent.STM -import Control.Monad (replicateM_) import Control.Monad.Catch -import Control.Monad.Fix (mfix) import Control.Monad.Reader (ReaderT, runReaderT, ask, lift) -import Data.Bifunctor qualified as Bifunctor import Data.Binary import Data.Binary.Get import Data.Binary.Put @@ -73,7 +70,6 @@ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.Proxy import Data.String (IsString(..)) -import Data.Kind (Type) import Data.Void (absurd) import GHC.Conc (unsafeIOToSTM) import GHC.TypeLits @@ -427,7 +423,7 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do nextIdVar <- newTVar (initialId @s) -- Create uninitialized to avoid use of a diverging 'mfix' - stateVar <- newTVar (Left impossibleCodePath) + stateVar <- newTVar (Left unreachableCodePath) let protocol = ProtocolHandle { stateVar @@ -446,20 +442,21 @@ initializeProtocol wlDisplayMessageHandler initializationAction = do writeTVar stateVar (Right state) messageHandlerVar <- newTVar (Just wlDisplayMessageHandler) - let wlDisplay = Object protocol (ObjectId wlDisplayId) messageHandlerVar - modifyTVar' objectsVar (HM.insert (GenericObjectId wlDisplayId) (SomeObject wlDisplay)) + let wlDisplay = Object protocol wlDisplayId messageHandlerVar + modifyTVar' objectsVar (HM.insert (toGenericObjectId wlDisplayId) (SomeObject wlDisplay)) result <- initializationAction wlDisplay pure (result, protocol) where - wlDisplayId = 1 + wlDisplayId :: ObjectId (InterfaceName wl_display) + wlDisplayId = ObjectId 1 -- | Run a protocol action in 'IO'. If an exception occurs, it is stored as a protocol failure and is then -- re-thrown. -- -- Throws an exception, if the protocol is already in a failed state. runProtocolTransaction :: MonadIO m => ProtocolHandle s -> ProtocolM s a -> m a -runProtocolTransaction (protocol@ProtocolHandle{stateVar}) action = do +runProtocolTransaction ProtocolHandle{stateVar} action = do result <- liftIO $ atomically do readTVar stateVar >>= \case -- Protocol is already in a failed state @@ -487,7 +484,7 @@ runProtocolM protocol action = either throwM (runReaderT action) =<< readTVar pr -- | Feed the protocol newly received data. -feedInput :: (IsSide s, MonadIO m, MonadThrow m) => ProtocolHandle s -> ByteString -> m () +feedInput :: (IsSide s, MonadIO m) => ProtocolHandle s -> ByteString -> m () feedInput protocol bytes = runProtocolTransaction protocol do -- Exposing MonadIO instead of STM to the outside and using `runProtocolTransaction` here enforces correct exception -- handling. @@ -496,11 +493,11 @@ feedInput protocol bytes = runProtocolTransaction protocol do receiveMessages -- | Set the protocol to a failed state, e.g. when the socket closed unexpectedly. -setException :: (Exception e, MonadIO m, MonadThrow m) => ProtocolHandle s -> e -> m () +setException :: (Exception e, MonadIO m) => ProtocolHandle s -> e -> m () setException protocol ex = runProtocolTransaction protocol $ throwM ex -- | Take data that has to be sent. Blocks until data is available. -takeOutbox :: (MonadIO m, MonadThrow m) => ProtocolHandle s -> m (BSL.ByteString) +takeOutbox :: MonadIO m => ProtocolHandle s -> m (BSL.ByteString) takeOutbox protocol = runProtocolTransaction protocol do mOutboxData <- stateProtocolVar (.outboxVar) (\mOutboxData -> (mOutboxData, Nothing)) outboxData <- maybe (lift retry) pure mOutboxData @@ -547,10 +544,9 @@ newObjectFromId messageHandler (NewId oId) = do protocol <- askProtocol messageHandlerVar <- lift $ newTVar messageHandler let - genericObjectId = toGenericObjectId oId object = Object protocol oId messageHandlerVar someObject = SomeObject object - modifyProtocolVar (.objectsVar) (HM.insert genericObjectId someObject) + modifyProtocolVar (.objectsVar) (HM.insert (genericObjectId object) someObject) pure object @@ -604,7 +600,7 @@ handleRawMessage (oId, opcode, body) = do Nothing -> throwM $ ProtocolException $ "Received message with invalid object id " <> show oId Just (SomeObject object) -> - case runGetOrFail (getMessageAction object opcode) body of + case runGetOrFail (getMessageAction object) body of Left (_, _, message) -> throwM $ ParserFailed (describeDownMessage object opcode body) message Right ("", _, result) -> result @@ -615,11 +611,10 @@ handleRawMessage (oId, opcode, body) = do throwM $ ProtocolException $ "Received message for object without handler: " <> interface <> "@" <> show oId where getMessageAction - :: forall s i. IsInterfaceSide s i + :: forall i. IsInterfaceSide s i => Object s i - -> Opcode -> Get (ProtocolM s ()) - getMessageAction object opcode = do + getMessageAction object = do verifyMessage <- getWireDown object opcode pure do message <- verifyMessage @@ -683,9 +678,6 @@ skipPadding = do bytes <- bytesRead skip $ fromIntegral (padding bytes) -paddedSize :: Integral a => a -> a -paddedSize size = size + padding size - padding :: Integral a => a -> a padding size = ((4 - (size `mod` 4)) `mod` 4) diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index f88d7d7bbec31fac4727030e09f41003e4d9cc58..c3743bc55e3bceabcf2c6ea3350067281e498aec 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -9,7 +9,7 @@ import Data.List (intersperse, singleton) import Data.Void (absurd) import GHC.Records import Language.Haskell.TH -import Language.Haskell.TH.Syntax (BangType, VarBangType, addDependentFile) +import Language.Haskell.TH.Syntax (addDependentFile) import Prelude qualified import Quasar.Prelude import Quasar.Wayland.Protocol.Core @@ -147,7 +147,6 @@ interfaceDecs interface = do where iName = interfaceN interface iT = interfaceT interface - sT = sideTVar wireRequestT :: Q Type wireRequestT = if length interface.requests > 0 then conT rTypeName else [t|Void|] rTypeName :: Name @@ -192,7 +191,9 @@ interfaceDecs interface = do eventProxyInstanceDecs = messageProxyInstanceDecs Server wireEventContexts handlerName = mkName "handler" + handlerP :: Q Pat handlerP = varP handlerName + handlerE :: Q Exp handlerE = varE handlerName interfaceSideInstanceDs :: Q [Dec] @@ -216,17 +217,17 @@ interfaceDecs interface = do msgHandlerE :: Q Exp msgHandlerE = [|$(appTypeE [|getField|] fieldNameLitT) $handlerE|] bodyE :: Q Exp - bodyE = [|lift =<< $(applyMsgArgs msg msgHandlerE)|] + bodyE = [|lift =<< $(applyMsgArgs msgHandlerE)|] - applyMsgArgs :: MessageContext -> Q Exp -> Q Exp - applyMsgArgs msg base = applyA base (argE <$> msg.msgSpec.arguments) + applyMsgArgs :: Q Exp -> Q Exp + applyMsgArgs base = applyA base (argE <$> msg.msgSpec.arguments) argE :: ArgumentSpec -> Q Exp argE arg = fromWireArgument arg.argType (msgArgE msg arg) fromWireArgument :: ArgumentType -> Q Exp -> Q Exp - fromWireArgument (ObjectArgument iName) objIdE = [|getObject $objIdE|] - fromWireArgument (NewIdArgument iName) objIdE = [|newObjectFromId Nothing $objIdE|] + fromWireArgument (ObjectArgument _) objIdE = [|getObject $objIdE|] + fromWireArgument (NewIdArgument _) objIdE = [|newObjectFromId Nothing $objIdE|] fromWireArgument _ x = [|pure $x|] messageProxyInstanceDecs :: Side -> [MessageContext] -> Q [Dec] @@ -257,7 +258,7 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa -- Constructor: the first argument becomes the return value ctorE :: Q Exp - ctorE = [|newObject Nothing >>= \(newObject, newId) -> newObject <$ (sendMessage object =<< $(msgE [|pure newId|]))|] + ctorE = [|newObject Nothing >>= \(newObj, newId) -> newObj <$ (sendMessage object =<< $(msgE [|pure newId|]))|] where msgE :: Q Exp -> Q Exp msgE idArgE = mkWireMsgE (idArgE : (wireArgE <$> args)) @@ -277,8 +278,8 @@ messageProxyInstanceDecs side messageContexts = mapM messageProxyInstanceD messa toWireArgument :: ArgumentType -> Q Exp -> Q Exp -- TODO verify object validity - toWireArgument (ObjectArgument iName) objectE = [|pure $objectE.objectId|] - toWireArgument (NewIdArgument _) _ = impossibleCodePath -- The specification parser has a check to prevent this + toWireArgument (ObjectArgument _) objectE = [|pure $objectE.objectId|] + toWireArgument (NewIdArgument _) _ = unreachableCodePath -- The specification parser has a check to prevent this toWireArgument _ x = [|pure $x|] proxyArguments :: MessageSpec -> [ArgumentSpec] @@ -306,11 +307,6 @@ messageHandlerRecordD side name messageContexts = dataD (cxt []) name [] Nothing applyArgTypes xt = foldr (\x y -> [t|$x -> $y|]) xt (argumentType side <$> msg.msgSpec.arguments) -sideTVarName :: Name -sideTVarName = mkName "s" -sideTVar :: Q Type -sideTVar = varT sideTVarName - sideT :: Side -> Q Type sideT Client = [t|'Client|] sideT Server = [t|'Server|] @@ -336,9 +332,6 @@ eventsName interface = mkName $ "EventHandler_" <> interface.name eventsT :: InterfaceSpec -> Maybe (Q Type) eventsT interface = if (length interface.events) > 0 then Just [t|$(conT (eventsName interface))|] else Nothing -orVoid :: Maybe (Q Type) -> Q Type -orVoid = fromMaybe [t|Void|] - orUnit :: Maybe (Q Type) -> Q Type orUnit = fromMaybe [t|()|] @@ -373,14 +366,6 @@ msgArgTempName :: ArgumentSpec -> Name -- Adds a prefix to prevent name conflicts with exports from the Prelude; would be better to use `newName` instead. msgArgTempName arg = mkName $ "arg_" <> arg.name -applyWireMsgArgs :: MessageContext -> Q Exp -> Q Exp -applyWireMsgArgs msg base = foldl appE base (msgArgE msg <$> msg.msgSpec.arguments) - --- | Expression to construct a wire message with arguments which have been matched using 'msgConP'/'msgArgPats'. --- TODO Unused? -wireMsgE :: MessageContext -> Q Exp -wireMsgE msg = applyWireMsgArgs msg (conE msg.msgConName) - messageTypeDecs :: Name -> [MessageContext] -> Q [Dec] messageTypeDecs name msgs = execWriterT do @@ -445,9 +430,6 @@ isMessageInstanceD t msgs = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, derivingEq :: Q DerivClause derivingEq = derivClause (Just StockStrategy) [[t|Eq|]] -derivingShow :: Q DerivClause -derivingShow = derivClause (Just StockStrategy) [[t|Show|]] - -- | Map an argument to its high-level api type argumentType :: Side -> ArgumentSpec -> Q Type argumentType side argSpec = liftArgumentType side argSpec.argType @@ -530,7 +512,7 @@ parseDescription element = do content <- case element.elContent of [Text CData{cdVerbatim=CDataText, cdData=content}] -> pure $ Just content [] -> pure Nothing - x -> fail $ "Cannot parse description xml: " <> show element + _ -> fail $ "Cannot parse description xml: " <> show element pure DescriptionSpec { summary, content @@ -572,12 +554,12 @@ parseMessage isRequest interface (opcode, element) = do name <- getAttr "name" element - let location = interface <> "." <> name + let loc = interface <> "." <> name mtype <- peekAttr "type" element since <- Prelude.read <<$>> peekAttr "since" element description <- findDescription element - arguments <- mapM (parseArgument location) $ zip [0..] $ findChildren (qname "arg") element + arguments <- mapM (parseArgument loc) $ zip [0..] $ findChildren (qname "arg") element isDestructor <- case mtype of @@ -587,22 +569,22 @@ parseMessage isRequest interface (opcode, element) = do when do isEvent && isDestructor - do fail $ "Event cannot be a destructor: " <> location + do fail $ "Event cannot be a destructor: " <> loc forM_ arguments \arg -> do when do arg.argType == GenericNewIdArgument && (interface /= "wl_registry" || name /= "bind") - do fail $ "Invalid \"new_id\" argument without \"interface\" attribute encountered on " <> location <> " (only valid on wl_registry.bind)" + do fail $ "Invalid \"new_id\" argument without \"interface\" attribute encountered on " <> loc <> " (only valid on wl_registry.bind)" when do arg.argType == GenericObjectArgument && (interface /= "wl_display" || name /= "error") - do fail $ "Invalid \"object\" argument without \"interface\" attribute encountered on " <> location <> " (only valid on wl_display.error)" + do fail $ "Invalid \"object\" argument without \"interface\" attribute encountered on " <> loc <> " (only valid on wl_display.error)" isConstructor <- case arguments of [] -> pure False (firstArg:otherArgs) -> do when do any (isNewId . (.argType)) otherArgs && not (interface == "wl_registry" && name == "bind") - do fail $ "Message uses NewId in unexpected position on: " <> location <> " (NewId must be the first argument, unless it is on wl_registry.bind)" + do fail $ "Message uses NewId in unexpected position on: " <> loc <> " (NewId must be the first argument, unless it is on wl_registry.bind)" pure (isNewId firstArg.argType) pure MessageSpec { @@ -624,12 +606,12 @@ parseArgument messageDescription (index, element) = do interface <- peekAttr "interface" element argType <- parseArgumentType argTypeStr interface - let location = messageDescription <> "." <> name + let loc = messageDescription <> "." <> name nullable <- peekAttr "allow-null" element >>= \case Just "true" -> pure True Just "false" -> pure False - Just x -> fail $ "Invalid value for attribute \"allow-null\" on " <> location <> ": " <> x + Just x -> fail $ "Invalid value for attribute \"allow-null\" on " <> loc <> ": " <> x Nothing -> pure False pure ArgumentSpec { name,