diff --git a/src/Quasar/Wayland/Protocol/Display.hs b/src/Quasar/Wayland/Protocol/Display.hs index 85a301195af85abdc378f7dba161becfc025dceb..3d17d5ffcc51cc9b5d149c7fa43f2d6a8849b2cc 100644 --- a/src/Quasar/Wayland/Protocol/Display.hs +++ b/src/Quasar/Wayland/Protocol/Display.hs @@ -3,11 +3,9 @@ module Quasar.Wayland.Protocol.Display ( ) where import Control.Monad.Catch -import Data.HashMap.Strict qualified as HM import Quasar.Prelude import Quasar.Wayland.Protocol.Core import Quasar.Wayland.Protocol.Generated -import Quasar.Wayland.Registry -- | Default implementation for @wl_display@ that handles errors and confirms deleted object ids. diff --git a/src/Quasar/Wayland/Protocol/Generated.hs b/src/Quasar/Wayland/Protocol/Generated.hs index 9de83835344e77a699ee5b652d42c97b392baaf6..f3d48c6e355352bfc6e0c53faca6c24e2861c9cb 100644 --- a/src/Quasar/Wayland/Protocol/Generated.hs +++ b/src/Quasar/Wayland/Protocol/Generated.hs @@ -7,6 +7,7 @@ module Quasar.Wayland.Protocol.Generated where -- Imports are here to improve readability when dumping splices import Control.Monad.Catch +import Control.Monad.STM import Data.Binary import Quasar.Prelude import Quasar.Wayland.Protocol.Core diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index c687e5b075976b15596622c724c14f13645feef7..613e77f242d89a6ab71792ce8a6620a22e2600f1 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -2,14 +2,12 @@ module Quasar.Wayland.Protocol.TH ( generateWaylandProcol ) where +import Control.Monad.STM import Control.Monad.Writer import Data.ByteString qualified as BS +import Data.List (intersperse) import Language.Haskell.TH import Language.Haskell.TH.Syntax (BangType, VarBangType, addDependentFile) -import Language.Haskell.TH.Syntax qualified as TH -import Data.ByteString qualified as BS -import Data.Int (Int32) -import Data.List (intersperse) import Prelude qualified import Quasar.Prelude import Quasar.Wayland.Protocol.Core @@ -95,7 +93,7 @@ interfaceDecs interface = do tellQ requestRecordD tellQ eventRecordD internals <- execWriterT do - tellQ $ dataD (pure []) iName [] Nothing [normalC iName []] [derivingInterfaceClient, derivingInterfaceServer] + tellQ $ dataD (pure []) iName [] Nothing [] [derivingInterfaceClient, derivingInterfaceServer] tellQ $ instanceD (pure []) [t|IsInterface $iT|] instanceDecs when (length interface.requests > 0) do @@ -146,31 +144,18 @@ interfaceDecs interface = do } eventContexts = eventContext <$> interface.events - aName :: Name - aName = mkName "a" - aType :: Q Type - aType = varT aName - mName :: Name - mName = mkName "m" - mType :: Q Type - mType = varT mName - sName :: Name - sName = mkName "s" - sType :: Q Type - sType = varT sName - requestRecordD :: Q Dec requestRecordD = messageRecordD (requestClassN interface) requestContexts eventRecordD :: Q Dec - eventRecordD = messageRecordD (eventClassN interface) requestContexts + eventRecordD = messageRecordD (eventClassN interface) eventContexts messageRecordD :: Name -> [MessageContext] -> Q Dec messageRecordD name messageContexts = dataD (cxt []) name [] Nothing [con] [] where con = recC name (recField <$> messageContexts) recField :: MessageContext -> Q VarBangType - recField msg = varDefaultBangType (mkName msg.msgSpec.name) [t|$(applyArgTypes [t|forall s. ProtocolM s ()|])|] + recField msg = varDefaultBangType (mkName msg.msgSpec.name) [t|$(applyArgTypes [t|STM ()|])|] where applyArgTypes :: Q Type -> Q Type applyArgTypes xt = foldr (\x y -> [t|$x -> $y|]) xt (argumentType <$> msg.msgSpec.arguments)