diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs
index 2f53d62e0e3359715c44b0c5812b7cf97954e03b..c4539fe41309f7b5111032070748056ac5b8e26d 100644
--- a/src/Quasar/Wayland/Protocol/Core.hs
+++ b/src/Quasar/Wayland/Protocol/Core.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE DeriveLift #-}
+
 module Quasar.Wayland.Protocol.Core (
   ObjectId,
   Opcode,
+  ArgumentType(..),
   Fixed,
   IsSide,
   Side(..),
@@ -49,6 +52,7 @@ import Data.Maybe (isJust)
 import Data.Typeable (Typeable, cast)
 import Data.Void (absurd)
 import GHC.TypeLits
+import Language.Haskell.TH.Syntax (Lift)
 import Quasar.Prelude
 
 
@@ -66,48 +70,72 @@ dropRemaining :: Get ()
 dropRemaining = void getRemainingLazyByteString
 
 
+
+data ArgumentType
+  = IntArgument
+  | UIntArgument
+  | FixedArgument
+  | StringArgument
+  | ArrayArgument
+  | ObjectArgument String
+  | UnknownObjectArgument
+  | NewIdArgument String
+  | UnknownNewIdArgument
+  | FdArgument
+  deriving stock (Show, Lift)
+
 class WireFormat a where
   type Argument a
   putArgument :: Argument a -> PutM ()
   getArgument :: Get (Argument a)
 
-instance WireFormat "int" where
-  type Argument "int" = Int32
+instance WireFormat 'IntArgument where
+  type Argument 'IntArgument = Int32
   putArgument = putInt32host
   getArgument = getInt32host
 
-instance WireFormat "uint" where
-  type Argument "uint" = Word32
+instance WireFormat 'UIntArgument where
+  type Argument 'UIntArgument = Word32
   putArgument = putWord32host
   getArgument = getWord32host
 
-instance WireFormat "fixed" where
-  type Argument "fixed" = Fixed
+instance WireFormat 'FixedArgument where
+  type Argument 'FixedArgument = Fixed
   putArgument (Fixed repr) = putWord32host repr
   getArgument = Fixed <$> getWord32host
 
-instance WireFormat "string" where
-  type Argument "string" = BS.ByteString
+instance WireFormat 'StringArgument where
+  type Argument 'StringArgument = BS.ByteString
   putArgument = putWaylandBlob
   getArgument = getWaylandBlob
 
-instance WireFormat "object" where
-  type Argument "object" = ObjectId
+instance WireFormat 'ArrayArgument where
+  type Argument 'ArrayArgument = BS.ByteString
+  putArgument = putWaylandBlob
+  getArgument = getWaylandBlob
+
+instance WireFormat 'ObjectArgument where
+  type Argument 'ObjectArgument = ObjectId
   putArgument = putWord32host
   getArgument = getWord32host
 
-instance WireFormat "new_id" where
-  type Argument "new_id" = NewId
+instance WireFormat 'UnknownObjectArgument where
+  type Argument 'UnknownObjectArgument = ObjectId
+  putArgument = putWord32host
+  getArgument = getWord32host
+
+instance WireFormat 'NewIdArgument where
+  type Argument 'NewIdArgument = NewId
   putArgument (NewId newId) = putWord32host newId
   getArgument = NewId <$> getWord32host
 
-instance WireFormat "array" where
-  type Argument "array" = BS.ByteString
-  putArgument = putWaylandBlob
-  getArgument = getWaylandBlob
+instance WireFormat 'UnknownNewIdArgument where
+  type Argument 'UnknownNewIdArgument = NewId
+  putArgument (NewId newId) = putWord32host newId
+  getArgument = NewId <$> getWord32host
 
-instance WireFormat "fd" where
-  type Argument "fd" = Void
+instance WireFormat 'FdArgument where
+  type Argument 'FdArgument = Void
   putArgument = undefined
   getArgument = undefined
 
diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs
index 6102400ac2ee9f4591e3adf9c3c3574fa3033524..e89bd81fdab5ad15202d529fa9f65b08b1c06737 100644
--- a/src/Quasar/Wayland/Protocol/TH.hs
+++ b/src/Quasar/Wayland/Protocol/TH.hs
@@ -8,6 +8,7 @@ import Data.ByteString qualified as BS
 import Language.Haskell.TH
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Syntax (addDependentFile)
+import Language.Haskell.TH.Syntax qualified as TH
 import Quasar.Prelude
 import Quasar.Wayland.Protocol.Core
 import Text.XML.Light
@@ -36,20 +37,6 @@ data MessageSpec = MessageSpec {
 }
   deriving stock Show
 
-
-data ArgumentType
-  = IntArgument
-  | UIntArgument
-  | FixedArgument
-  | StringArgument
-  | ArrayArgument
-  | ObjectArgument String
-  | UnknownObjectArgument
-  | NewIdArgument String
-  | UnknownNewIdArgument
-  | FdArgument
-  deriving stock Show
-
 data ArgumentSpec = ArgumentSpec {
   name :: String,
   argType :: ArgumentType
@@ -148,6 +135,14 @@ derivingInterfaceClient = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSid
 derivingInterfaceServer :: Q DerivClause
 derivingInterfaceServer = derivClause (Just AnyclassStrategy) [[t|IsInterfaceSide 'Server|]]
 
+promoteArgumentType :: ArgumentType -> Q Type
+promoteArgumentType arg = do
+  argExp <- (TH.lift arg)
+  ConT <$> matchCon argExp
+  where
+    matchCon :: Exp -> Q Name
+    matchCon (ConE name) = pure name
+    matchCon _ = fail "Can only promote ConE expression"
 
 
 -- * XML parser