finish codegen

9 files changed, 277 insertions, 178 deletions

diff --git a/highway/Main.hs b/highway/Main.hs
index 481ec33..0749499 100644
--- a/highway/Main.hs
+++ b/highway/Main.hs
@@ -22,6 +22,13 @@ geometry = WlOutput.Geometry { WlOutput.geometryX              = 0
                              , WlOutput.geometryTransform      = WlOutput.TransformNormal
                              }
 
+mode :: WlOutput.Mode
+mode = WlOutput.Mode { WlOutput.modeFlags   = [WlOutput.ModeFlagCurrent, WlOutput.ModeFlagPreferred]
+                     , WlOutput.modeWidth   = 5120
+                     , WlOutput.modeHeight  = 2880
+                     , WlOutput.modeRefresh = 60000
+                     }
+
 data CustomMessage
   = MsgBindOutput    Global (NewObject WlOutput.Object)
   | MsgDestroyOutput WlOutput.Object
@@ -47,7 +54,8 @@ handleMessage m
   | Just (MsgBindOutput _ o)     <- fromMessage m = do output <- createObject o MsgDestroyOutput
                                                        outs <- outputs <%= M.insert output Output
                                                        sendEvent output $ WlOutput.EvGeometry geometry
-                                                       sendEvent output $ WlOutput.EvDone
+                                                       sendEvent output $ WlOutput.EvMode mode
+                                                       sendEvent output WlOutput.EvDone
                                                        liftIO $ putStrLn $ "Output created, outputs: " ++ show outs
                                                        flushEvents
   | Just (MsgDestroyOutput o)    <- fromMessage m = do outputs %= M.delete o
diff --git a/protocols/codegen/Main.hs b/protocols/codegen/Main.hs
index dbe1577..ec12592 100644
--- a/protocols/codegen/Main.hs
+++ b/protocols/codegen/Main.hs
@@ -45,8 +45,13 @@ writeInterface :: FlatModules -> FilePath -> TypedProtocol -> TypedInterfaceDesc
 writeInterface flat dir p i = do
   let path     = dir </> (interfaceModule (fst i) ++ ".hs")
   let bootPath = dir </> (interfaceModule (fst i) ++ ".hs-boot")
-  writeFile path (generateInterface flat p i)
-  writeFile bootPath (generateInterfaceBoot flat p i)
+  let cfg      = GeneratorConfig { genModules = flat
+                                 , genProtocol = p
+                                 , genInterface = fst i
+                                 , genTypes = snd i
+                                 }
+  writeFile path (generateInterface cfg)
+  writeFile bootPath (generateInterfaceBoot cfg)
 
 writeBuild :: FilePath -> [Protocol] -> IO ()
 writeBuild path ps = writeFile path $ generateBuild ps
diff --git a/protocols/codegen/Wayland/CodeGen/BuildGen.hs b/protocols/codegen/Wayland/CodeGen/BuildGen.hs
index 4b6a4e8..900360d 100644
--- a/protocols/codegen/Wayland/CodeGen/BuildGen.hs
+++ b/protocols/codegen/Wayland/CodeGen/BuildGen.hs
@@ -24,6 +24,7 @@ generateBuild protocols = unlines ([ "cabal-version:      3.0"
                                    , "    import:           warnings"
                                    , "    build-depends:    base,"
                                    , "                      hashable,"
+                                   , "                      mtl,"
                                    , "                      bytestring,"
                                    , "                      highway-wayland"
                                    , "    default-language: Haskell2010" ]
diff --git a/protocols/codegen/Wayland/CodeGen/CodeGen.hs b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
index 517199a..67d02dd 100644
--- a/protocols/codegen/Wayland/CodeGen/CodeGen.hs
+++ b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Wayland.CodeGen.CodeGen
-  ( generateInterface
+  ( GeneratorConfig(..)
+  , generateInterface
   , generateInterfaceBoot
   ) where
 
@@ -17,7 +18,6 @@ import Data.Functor (($>))
 import Control.Monad.Reader (ReaderT (..), asks)
 import Data.Map ((!))
 import qualified Data.Map as M
-import Data.Maybe (isJust)
 
 newtype Declaration = Declaration { declLines :: [String] }
 data Import = Import { imModule :: !String
@@ -43,14 +43,14 @@ type Generator = ReaderT GeneratorConfig (State GeneratorState)
 
 makeLenses ''GeneratorState
 
-generateInterface :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
-generateInterface flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emit
+generateInterface :: GeneratorConfig -> String
+generateInterface = generate emit
 
-generateInterfaceBoot :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
-generateInterfaceBoot flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emitBoot
+generateInterfaceBoot :: GeneratorConfig -> String
+generateInterfaceBoot = generate emitBoot
 
-generate :: GeneratorConfig -> Generator () -> String
-generate cfg g = transform $ runState (runReaderT g cfg) initialState
+generate :: Generator () -> GeneratorConfig -> String
+generate g cfg = transform $ runState (runReaderT g cfg) initialState
   where initialState = GeneratorState { _stateImports       = []
                                       , _stateExports       = []
                                       , _stateExtensions    = []
@@ -92,18 +92,25 @@ resolveInterface (Just name) e = do modules <- asks genModules
                                     resolve (fullModule p (fst i)) e
 resolveInterface Nothing     e = pure e
 
+wrapEnumArray :: String -> EnumDesc -> String
+wrapEnumArray name e = if enumBitfield e then "[" ++ name ++ "]" else name
+
 resolveEnum :: String -> Generator String
 resolveEnum e = resolveQualified $ break (== '.') e
   where resolveQualified :: (String, String) -> Generator String
         resolveQualified (e', [])   = do types <- asks genTypes
-                                         pure $ typeEnums types ! e'
+                                         let EnumName desc name = typeEnums types ! e'
+                                         pure $ wrapEnumArray name desc
         resolveQualified (i,  _:e') = do modules <- asks genModules
-                                         resolveInterface (Just i) $ typeEnums (snd (snd (modules ! i))) ! e'
+                                         let iface = snd (modules ! i)
+                                         let EnumName desc name = typeEnums (snd iface) ! e'
+                                         resolved <- resolveInterface (Just i) name
+                                         pure $ wrapEnumArray resolved desc
 
 resolveArgument :: ArgumentDesc -> Generator String
 resolveArgument a = case argType a of
-                      ArgumentInt    -> maybe (pure "Int")  resolveEnum (argEnum a)
-                      ArgumentUInt   -> maybe (pure "Word") resolveEnum (argEnum a)
+                      ArgumentInt    -> maybe (resolve "Foreign" "Int32")  resolveEnum (argEnum a)
+                      ArgumentUInt   -> maybe (resolve "Foreign" "Word32") resolveEnum (argEnum a)
                       ArgumentFixed  -> pure "Float"
                       ArgumentArray  -> resolve "Data.ByteString" "ByteString"
                       ArgumentFD     -> resolve "System.Posix.Types" "Fd"
@@ -116,23 +123,27 @@ resolveArgument a = case argType a of
 
 emitBoot :: Generator ()
 emitBoot = do
-  anyObject     <- resolve "Wayland.Server" "AnyObject"
-  interfaceDesc <- resolve "Wayland.Server" "InterfaceDesc"
-  objectClass   <- resolve "Wayland.Server" "Object"
-  enumTypes     <- asks $ typeEnums . genTypes
-  i             <- asks genInterface
+  anyObject         <- resolve "Wayland.Server" "AnyObject"
+  interfaceDesc     <- resolve "Wayland.Server" "InterfaceDesc"
+  objectClass       <- resolve "Wayland.Server" "Object"
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  enumTypes         <- asks $ typeEnums . genTypes
+  i                 <- asks genInterface
+  emitExtension "FlexibleInstances"
   emitDecl [ "newtype Object = Object " ++ anyObject ]
   emitExport "Object"
   emitDecl [ "interface :: " ++ interfaceDesc ]
   emitExport "interface"
   emitDecl [ "instance " ++ objectClass ++ " Object"
            , "instance Show Object"
-           , "instance Eq Object" ]
-  let emitEnumBoot e = do let name = enumTypes ! enumName e
+           , "instance Eq Object"
+           , "instance " ++ marshallableClass ++ " Object"
+           , "instance " ++ marshallableClass ++ " (Maybe Object)" ]
+  let emitEnumBoot e = do let EnumName _ name = enumTypes ! enumName e
                           emitDecl [ "data " ++ name
                                    , "instance Show " ++ name
                                    , "instance Eq " ++ name
-                                   , "instance Enum " ++ name ]
+                                   , "instance " ++ marshallableClass ++ " " ++ (if enumBitfield e then "[" ++ name ++ "]" else name) ]
                           emitExport name
   mapM_ emitEnumBoot (ifEnums i)
 
@@ -141,10 +152,12 @@ emit = do
   anyObject     <- resolve "Wayland.Server" "AnyObject"
   hashable      <- resolve "Data.Hashable" "Hashable"
   objectClass   <- resolve "Wayland.Server" "Object"
+  throwError'   <- resolve "Control.Monad.Except" "throwError"
   i             <- asks genInterface
   types         <- asks genTypes
   emitExtension "GeneralizedNewtypeDeriving"
   emitExtension "EmptyDataDeriving"
+  emitExtension "FlexibleInstances"
   emitDecl [ "newtype Object = Object " ++ anyObject
            , "  deriving (Show, Eq, Ord, " ++ hashable ++ ")" ]
   emitExport "Object"
@@ -158,9 +171,9 @@ emit = do
   mapM_ emitArguments (typeEventArgs   types)
   emitExtension "TypeFamilies"
   let matchArgument m msgTypes = case msgTypes ! msgName m of
-                                   ArgumentModeNone       -> ""
-                                   ArgumentModeSingle _   -> " _"
-                                   ArgumentModeRecord _ _ -> " _"
+                                   ArgumentNameNone       -> ""
+                                   ArgumentNameSingle _   -> " _"
+                                   ArgumentNameRecord _ _ -> " _"
   let requestSignature m =
         "  requestSignature _ (Req" ++ pascalCase (msgName m) ++ " _" ++ matchArgument m (typeRequestArgs types) ++ ") = req" ++ pascalCase (msgName m)
   let eventSignature m =
@@ -174,13 +187,23 @@ emit = do
             , "  fromAny = Object"
             , "  describeInterface _ = interface" ]
             ++ demarshalRequests ++
-            [ "  demarshalRequest _ _ = undefined" ]
+            [ "  demarshalRequest o c = " ++ throwError' ++ " $ \"Unknown opcode \" ++ show c ++ \" on \" ++ show o" ]
             ++ marshalEvents ++
             [ "  marshalEvent _ _ = undefined" ]
             ++ fmap requestSignature (ifRequests i) ++
             [ "  requestSignature _ _ = undefined" ]
             ++ fmap eventSignature (ifEvents i) ++
             [ "  eventSignature _ _ = undefined" ])
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshal'          <- resolve "Wayland.Server" "marshal"
+  demarshal'        <- resolve "Wayland.Server" "demarshal"
+  emitDecl [ "instance " ++ marshallableClass ++ " Object where"
+           , "  marshal (Object o) = " ++ marshal' ++ " o"
+           , "  demarshal = Object <$> " ++ demarshal' ]
+  emitDecl [ "instance " ++ marshallableClass ++ " (Maybe Object) where"
+           , "  marshal (Just (Object o)) = " ++ marshal' ++ " (Just o)"
+           , "  marshal Nothing           = " ++ marshal' ++ " (Nothing :: Maybe " ++ anyObject ++ ")"
+           , "  demarshal = fmap (Object <$>) " ++ demarshal' ]
 
 requestDescName :: MessageDesc -> String
 requestDescName m = "req" ++ pascalCase (msgName m)
@@ -255,16 +278,16 @@ emitRequests ms = emitMessages ms typeRequestArgs (\m -> requestConstructor m ++
 emitEvents :: [MessageDesc] -> Generator ()
 emitEvents ms = emitMessages ms typeEventArgs eventConstructor "Event"
 
-emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentMode) -> (MessageDesc -> String) -> String -> Generator ()
+emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentName) -> (MessageDesc -> String) -> String -> Generator ()
 emitMessages ms argTypes formatConstructor type' = do
   typeable     <- resolve "Data.Typeable" "Typeable"
   messageClass <- resolve "Wayland.Server" "MessageClass"
   typeClass    <- resolve "Wayland.Server" (type' ++ "Class")
   args         <- asks $ argTypes . genTypes
-  let constructorArg :: ArgumentMode -> Generator String
-      constructorArg ArgumentModeNone         = pure ""
-      constructorArg (ArgumentModeSingle a)   = (++) " " <$> resolveArgument a
-      constructorArg (ArgumentModeRecord _ r) = pure $ " " ++ r
+  let constructorArg :: ArgumentName -> Generator String
+      constructorArg ArgumentNameNone         = pure ""
+      constructorArg (ArgumentNameSingle a)   = (++) " " <$> resolveArgument a
+      constructorArg (ArgumentNameRecord _ r) = pure $ " " ++ r
   let constructor m = (++) (formatConstructor m) <$> constructorArg (args ! msgName m)
   constructors <- mapM constructor ms
   emitDecl $ [ "data " ++ type' ]
@@ -277,73 +300,35 @@ emitMessages ms argTypes formatConstructor type' = do
 demarshalRequest :: MessageDesc -> Generator [String]
 demarshalRequest m = do
   args <- asks $ typeRequestArgs . genTypes
-  let demarshalledValue :: ArgumentDesc -> Generator String
-      demarshalledValue a = case argType a of
-                              ArgumentInt    -> do demarshalInt' <- resolve "Wayland.Server" "demarshalInt"
-                                                   if isJust (argEnum a) then pure $ "(toEnum <$> " ++ demarshalInt' ++ ")"
-                                                                         else pure demarshalInt'
-                              ArgumentUInt   -> do demarshalUInt' <- resolve "Wayland.Server" "demarshalUInt"
-                                                   if isJust (argEnum a) then pure $ "(toEnum . fromIntegral <$> " ++ demarshalUInt' ++ ")"
-                                                                         else pure demarshalUInt'
-                              ArgumentFixed  -> resolve "Wayland.Server" "demarshalFixed"
-                              ArgumentArray  -> resolve "Wayland.Server" "demarshalArray"
-                              ArgumentFD     -> resolve "Wayland.Server" "demarshalFD"
-                              ArgumentString -> if argAllowNull a then resolve "Wayland.Server" "demarshalMaybeString"
-                                                                  else resolve "Wayland.Server" "demarshalString"
-                              ArgumentObject -> if argAllowNull a then resolve "Wayland.Server" "demarshalMaybeObject"
-                                                                  else resolve "Wayland.Server" "demarshalObject"
-                              ArgumentNewID  -> resolve "Wayland.Server" "demarshalNewID"
+  demarshal' <- resolve "Wayland.Server" "demarshal"
   case args ! msgName m of
-    ArgumentModeNone        -> pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = pure $ " ++ requestConstructor m ++ " o" ]
-    ArgumentModeSingle a    -> do val <- demarshalledValue a
-                                  pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = " ++ requestConstructor m ++ " o <$> " ++ val ]
-    ArgumentModeRecord as r -> do vals <- mapM demarshalledValue as
-                                  let demarshal (val, a) = "    " ++ camelCase (argName a) ++ "' <- " ++ val
-                                  let formatArgs []      = [ "      {" ]
-                                      formatArgs (a:as') =  ("      { " ++ recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'") : fmap formatArg' as'
-                                      formatArg' a       =   "      , " ++ recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'"
+    ArgumentNameNone        -> pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = pure $ " ++ requestConstructor m ++ " o" ]
+    ArgumentNameSingle _    -> do pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = " ++ requestConstructor m ++ " o <$> " ++ demarshal' ]
+    ArgumentNameRecord as r -> do let apply a = "    " ++ camelCase (argName a) ++ "' <- " ++ demarshal'
+                                  let field a = recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'"
                                   pure ([ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = do" ]
-                                        ++ fmap demarshal (zip vals as) ++
+                                        ++ fmap apply as ++
                                         [ "    pure $ " ++ requestConstructor m ++ " o $ " ++ r ]
-                                        ++ formatArgs as ++
-                                        [ "      }" ])
+                                        ++ formatBrackets "      {" "      ," "      }" (fmap field as))
 
 marshalEvent :: MessageDesc -> Generator [String]
 marshalEvent m = do
   args <- asks $ typeEventArgs . genTypes
-  let marshalFunc :: ArgumentDesc -> Generator String
-      marshalFunc a = case argType a of
-                        ArgumentInt    -> do marshalInt' <- resolve "Wayland.Server" "marshalInt"
-                                             if isJust (argEnum a) then pure $ "(" ++ marshalInt' ++ " . fromEnum)"
-                                                                   else pure marshalInt'
-                        ArgumentUInt   -> do marshalUInt' <- resolve "Wayland.Server" "marshalUInt"
-                                             if isJust (argEnum a) then pure $ "(" ++ marshalUInt' ++ " . fromIntegral . fromEnum)"
-                                                                   else pure marshalUInt'
-                        ArgumentFixed  -> resolve "Wayland.Server" "marshalFixed"
-                        ArgumentArray  -> resolve "Wayland.Server" "marshalArray"
-                        ArgumentFD     -> resolve "Wayland.Server" "marshalFD"
-                        ArgumentString -> if argAllowNull a then resolve "Wayland.Server" "marshalMaybeString"
-                                                            else resolve "Wayland.Server" "marshalString"
-                        ArgumentObject -> if argAllowNull a then resolve "Wayland.Server" "marshalMaybeObject"
-                                                            else resolve "Wayland.Server" "marshalObject"
-                        ArgumentNewID  -> resolve "Wayland.Server" "marshalNewID"
+  marshal' <- resolve "Wayland.Server" "marshal"
   case args ! msgName m of
-    ArgumentModeNone        -> pure [ "  marshalEvent _ " ++ eventConstructor m ++ " = pure " ++ show (msgOpCode m) ]
-    ArgumentModeSingle a    -> do func <- marshalFunc a
-                                  pure [ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do"
-                                       , "    " ++ func ++ " x"
+    ArgumentNameNone        -> pure [ "  marshalEvent _ " ++ eventConstructor m ++ " = pure " ++ show (msgOpCode m) ]
+    ArgumentNameSingle _    -> do pure [ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do"
+                                       , "    " ++ marshal' ++ " x"
                                        , "    pure " ++ show (msgOpCode m) ]
-    ArgumentModeRecord as r -> do funcs <- mapM marshalFunc as
-                                  let apply (func, a) = "    " ++ func ++ " $ " ++ recordField r (camelCase (argName a)) ++ " x"
+    ArgumentNameRecord as r -> do let apply a = "    " ++ marshal' ++ " $ " ++ recordField r (camelCase (argName a)) ++ " x"
                                   pure ([ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do" ]
-                                        ++ fmap apply (zip funcs as) ++
+                                        ++ fmap apply as ++
                                         [ "    pure " ++ show (msgOpCode m) ])
 
 emitEnum :: EnumDesc -> Generator ()
 emitEnum e = do
-  -- TODO: Handle bitsets
   types <- asks $ typeEnums . genTypes
-  let name = types ! enumName e
+  let EnumName _ name = types ! enumName e
   let constructorName entry = name ++ pascalCase (entryName entry)
   let constructorNames = fmap constructorName (enumEntries e)
   let constructors = dataConstructors constructorNames
@@ -351,30 +336,65 @@ emitEnum e = do
             ++ constructors ++
             [ "  deriving (Show, Eq)" ])
   emitExport $ name ++ "(..)"
-  let fromEnum' (c, i) = "  fromEnum " ++ c ++ " = " ++ show i
-  let toEnum' (c, i) = "  toEnum " ++ show i ++ " = " ++ c
-  let constructorValues = zip constructorNames (fmap entryValue (enumEntries e))
-  emitDecl ([ "instance Enum " ++ name ++ " where" ]
-            ++ fmap toEnum' constructorValues ++
-            [ "  toEnum _ = undefined" ]
-            ++ fmap fromEnum' constructorValues)
+  let values = zip constructorNames (fmap entryValue (enumEntries e))
+  (if enumBitfield e then emitMarshallableBitfield else emitMarshallableEnum) name values
 
-emitArguments :: ArgumentMode -> Generator ()
-emitArguments  ArgumentModeNone              = pure ()
-emitArguments (ArgumentModeSingle _)         = pure ()
-emitArguments (ArgumentModeRecord args name) = do
-  let field a = recordField name (camelCase (argName (fst a))) ++ " :: " ++ snd a
-  let formatArgs []     = [ "    {" ]
-      formatArgs (a:as) =  ("    { " ++ field a) : fmap formatArg' as
-      formatArg' a      =   "    , " ++ field a
+emitMarshallableEnum :: String -> [(String, Int)] -> Generator ()
+emitMarshallableEnum name values = do
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshalUInt'      <- resolve "Wayland.Server" "marshalUInt"
+  demarshalUInt'    <- resolve "Wayland.Server" "demarshalUInt"
+  throwError'       <- resolve "Control.Monad.Except" "throwError"
+  let marshal (c, i) = "  marshal " ++ c ++ " = " ++ marshalUInt' ++ " " ++ show i
+  let demarshalCase (c, i) = "      " ++ show i ++ " -> pure " ++ c
+  emitDecl ([ "instance " ++ marshallableClass ++ " " ++ name ++ " where" ]
+            ++ fmap marshal values ++
+            [ "  marshal _ = undefined"
+            , "  demarshal = do"
+            , "    x <- " ++ demarshalUInt'
+            , "    case x of" ]
+            ++ fmap demarshalCase values ++
+            [ "      _ -> " ++ throwError' ++ " $ \"Unknown enum value for type " ++ name ++ ": \" ++ show x" ])
+
+emitMarshallableBitfield :: String -> [(String, Int)] -> Generator ()
+emitMarshallableBitfield name values = do
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshalUInt'      <- resolve "Wayland.Server" "marshalUInt"
+  demarshalUInt'    <- resolve "Wayland.Server" "demarshalUInt"
+  catMaybes'        <- resolve "Data.Maybe" "catMaybes"
+  bitOr             <- resolve "Foreign" ".|."
+  bitAnd            <- resolve "Foreign" ".&."
+  let marshalVal (c, i) = "      val " ++ c ++ " = " ++ show i
+  let demarshalVal (c, i) = "val " ++ show i ++ " " ++ c
+  emitDecl ([ "instance " ++ marshallableClass ++ " [" ++ name ++ "] where"
+            , "  marshal = " ++ marshalUInt' ++ " . foldr ((" ++ bitOr ++ ") . val) 0"
+            , "    where" ]
+            ++ fmap marshalVal values ++
+            [ "      val _ = undefined"
+            , "  demarshal = do"
+            , "    x <- " ++ demarshalUInt'
+            , "    let val v v' = if x " ++ bitAnd ++ " v == v then Just v' else Nothing"
+            , "    pure $ " ++ catMaybes' ]
+            ++ formatBrackets "      [" "      ," "      ]" (fmap demarshalVal values))
+
+emitArguments :: ArgumentName -> Generator ()
+emitArguments  ArgumentNameNone              = pure ()
+emitArguments (ArgumentNameSingle _)         = pure ()
+emitArguments (ArgumentNameRecord args name) = do
+  let field (a, aName) = recordField name (camelCase (argName a)) ++ " :: " ++ aName
   resolvedArgs <- mapM resolveArgument args
   emitDecl ([ "data " ++ name
             , "  = " ++ name ]
-            ++ formatArgs (zip args resolvedArgs) ++
-            [ "    }"
-            , "  deriving (Show, Eq)" ])
+            ++ formatBrackets "    {" "    ," "    }" (fmap field (zip args resolvedArgs)) ++
+            [ "  deriving (Show, Eq)" ])
   emitExport $ name ++ "(..)"
 
+formatBrackets :: String -> String -> String -> [String] -> [String]
+formatBrackets open sep close ls = format ls ++ [close]
+  where format []     = [open]
+        format (x:xs) = (open ++ " " ++ x) : fmap format' xs
+        format' x     =  sep  ++ " " ++ x
+
 dataConstructors :: [String] -> [String]
 dataConstructors (c:cs) = ("  = " ++ c) : fmap ("  | " ++) cs
 dataConstructors []     = []
diff --git a/protocols/codegen/Wayland/CodeGen/Types.hs b/protocols/codegen/Wayland/CodeGen/Types.hs
index 5f2c232..b582a27 100644
--- a/protocols/codegen/Wayland/CodeGen/Types.hs
+++ b/protocols/codegen/Wayland/CodeGen/Types.hs
@@ -10,7 +10,8 @@ module Wayland.CodeGen.Types
   , MessageType(..)
   , ArgumentDesc(..)
   , ArgumentType(..)
-  , ArgumentMode(..)
+  , ArgumentName(..)
+  , EnumName(..)
   , Description(..)
   , TypeInfo(..)
   , emptyTypeInfo
@@ -106,16 +107,20 @@ data Description
                 }
   deriving Show
 
-data ArgumentMode
-  = ArgumentModeNone
-  | ArgumentModeSingle ArgumentDesc
-  | ArgumentModeRecord [ArgumentDesc] String
+data ArgumentName
+  = ArgumentNameNone
+  | ArgumentNameSingle ArgumentDesc
+  | ArgumentNameRecord [ArgumentDesc] String
+  deriving Show
+
+data EnumName
+  = EnumName EnumDesc String
   deriving Show
 
 data TypeInfo
-  = TypeInfo { typeRequestArgs :: !(M.Map String ArgumentMode)
-             , typeEventArgs   :: !(M.Map String ArgumentMode)
-             , typeEnums       :: !(M.Map String String)
+  = TypeInfo { typeRequestArgs :: !(M.Map String ArgumentName)
+             , typeEventArgs   :: !(M.Map String ArgumentName)
+             , typeEnums       :: !(M.Map String EnumName)
              }
   deriving Show
 
@@ -128,6 +133,7 @@ emptyTypeInfo = TypeInfo { typeRequestArgs = M.empty
 isTypeFree :: String -> TypeInfo -> Bool
 isTypeFree name types = not $ any (argMatches name) (typeRequestArgs types)
                            || any (argMatches name) (typeEventArgs   types)
-                           || name `elem` typeEnums types
-  where argMatches n (ArgumentModeRecord _ n') = n == n'
+                           || any (enumMatches name) (typeEnums types)
+  where argMatches n (ArgumentNameRecord _ n') = n == n'
         argMatches _ _                         = False
+        enumMatches n (EnumName _ n') = n == n'
diff --git a/protocols/codegen/Wayland/CodeGen/Utils.hs b/protocols/codegen/Wayland/CodeGen/Utils.hs
index fa04286..9f43ab0 100644
--- a/protocols/codegen/Wayland/CodeGen/Utils.hs
+++ b/protocols/codegen/Wayland/CodeGen/Utils.hs
@@ -66,14 +66,15 @@ resolveInterfaceTypes i = do
   mapM_ (\m -> resolveAndAssign (resolveMessageType m) (assignRequestArgs (msgName  m))) (ifRequests i)
   mapM_ (\e -> resolveAndAssign (resolveEnumType    e) (assignEnumName    (enumName e))) (ifEnums    i)
 
-resolveMessageType :: MessageDesc -> State TypeInfo ArgumentMode
+resolveMessageType :: MessageDesc -> State TypeInfo ArgumentName
 resolveMessageType m = case msgArguments m of
-                         []  -> pure ArgumentModeNone
-                         [a] -> pure $ ArgumentModeSingle a
-                         as  -> ArgumentModeRecord as <$> getFreeTypeName (pascalCase (msgName m)) Nothing
+                         []  -> pure ArgumentNameNone
+                         [a] -> pure $ ArgumentNameSingle a
+                         as  -> ArgumentNameRecord as <$> getFreeTypeName (pascalCase (msgName m)) Nothing
 
-resolveEnumType :: EnumDesc -> State TypeInfo String
-resolveEnumType e = getFreeTypeName (pascalCase (enumName e)) $ if enumBitfield e then Just "Flags" else Nothing
+resolveEnumType :: EnumDesc -> State TypeInfo EnumName
+resolveEnumType e = EnumName e <$> name
+  where name = getFreeTypeName (pascalCase (enumName e)) $ if enumBitfield e then Just "Flag" else Nothing
 
 getFreeTypeName :: String -> Maybe String -> State TypeInfo String
 getFreeTypeName requested conflictSuffix = attemptRequested
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
index 07fc3d7..0e18048 100644
--- a/wayland/Wayland/Server.hs
+++ b/wayland/Wayland/Server.hs
@@ -54,6 +54,7 @@ module Wayland.Server
   , EventClass
   , ArgumentMarshaller(..)
   , ArgumentDemarshaller(..)
+  , Marshallable(..)
   ) where
 
 import Wayland.Server.Interface
diff --git a/wayland/Wayland/Server/Display.hs b/wayland/Wayland/Server/Display.hs
index 527d9da..2594330 100644
--- a/wayland/Wayland/Server/Display.hs
+++ b/wayland/Wayland/Server/Display.hs
@@ -338,7 +338,8 @@ flushClientEvents c = liftIO (unwrapClient c >>= wlClientFlush)
 -- The object is published through the global wl_registry instance. When a client wants to instantiate the global
 -- object, the given "bind" message will be dispatched in the message loop.
 registerGlobal
-  :: forall o bindMsg s. Object o
+  :: forall o bindMsg s
+  . Object o
   => MessageClass bindMsg
   => (Global -> NewObject o -> bindMsg) -- ^ Function used to create a message to bind the global object for a client.
   -> DisplayM s Global                  -- ^ Display monad wrapping a handle to the global which can be used to unregister it.
@@ -394,7 +395,7 @@ createObject o destroyHook = do
 -- This will invoke the object's "destroy" hook.
 destroyObject :: Object o => o -> DisplayM s ()
 destroyObject o = liftIO $ do
-  ptr <- unwrapResource o
+  ptr <- unwrapResource (toAny o)
   wlResourceDestroy ptr
 
 -- | Send an event for an object to the client it is associated with.
@@ -510,11 +511,12 @@ unregisterFileSource file = liftIO $ do
   freeHaskellFunPtr (fileFunc file)
 
 fromFileEventMask :: FileEventMask -> Word32
-fromFileEventMask events = conditionalMask wlEventReadable (fileEventReadable events)
-                         $ conditionalMask wlEventWritable (fileEventWritable events)
-                         $ conditionalMask wlEventHangup   (fileEventHangup   events)
-                         $ conditionalMask wlEventError    (fileEventError    events) 0
-  where conditionalMask mask enabled x = if enabled then x .|. mask else x
+fromFileEventMask events = 0
+                         .|. conditionalMask wlEventReadable (fileEventReadable events)
+                         .|. conditionalMask wlEventWritable (fileEventWritable events)
+                         .|. conditionalMask wlEventHangup   (fileEventHangup   events)
+                         .|. conditionalMask wlEventError    (fileEventError    events)
+  where conditionalMask mask enabled = if enabled then mask else 0
 
 toFileEventMask :: Word32 -> FileEventMask
 toFileEventMask bits = FileEventMask { fileEventReadable = testMask wlEventReadable
diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs
index b13e36f..1fec556 100644
--- a/wayland/Wayland/Server/Object.hs
+++ b/wayland/Wayland/Server/Object.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 -- |
 -- Module     : Wayland.Server.Object
@@ -23,6 +24,7 @@ module Wayland.Server.Object
   , EventClass
   , ArgumentMarshaller(..)
   , ArgumentDemarshaller(..)
+  , Marshallable(..)
   , -- * State
     ObjectCache
   , ObjectCacheState
@@ -50,6 +52,7 @@ import Control.Monad.State.Strict (StateT(..), MonadState(..))
 import Control.Monad.Cont (ContT(..))
 import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
 import Control.Monad.Reader (ReaderT (..), MonadReader(..))
+import Control.Monad.Except (MonadError (..), ExceptT, runExceptT)
 import Wayland.Server.System
 import Wayland.Server.Interface (MessageDesc(..), InterfaceDesc(..), InterfaceCache, newInterfaceCache, destroyInterfaceCache, resolveInterface)
 import Wayland.Server.Client (Client, unwrapClient, wrapClient)
@@ -114,32 +117,33 @@ class MessageClass e => EventClass e where
 -- For libwayland, the arguments are stored into wl_arguments. It is considered a programmer error to write more
 -- arguments than expected by an event or different argument types than the ones specified.
 class Monad m => ArgumentMarshaller m where
-  marshalInt         :: Int                     -> m ()
-  marshalUInt        :: Word                    -> m ()
-  marshalFixed       :: Float                   -> m ()
-  marshalString      :: String                  -> m ()
-  marshalMaybeString :: Maybe String            -> m ()
-  marshalObject      :: Object o => o           -> m ()
-  marshalMaybeObject :: Object o => Maybe o     -> m ()
-  marshalNewID       :: Object o => NewObject o -> m ()
-  marshalArray       :: ByteString              -> m ()
-  marshalFD          :: Fd                      -> m ()
+  marshalInt    :: Int32                   -> m ()
+  marshalUInt   :: Word32                  -> m ()
+  marshalFixed  :: Float                   -> m ()
+  marshalString :: Maybe String            -> m ()
+  marshalObject :: Maybe AnyObject         -> m ()
+  marshalNewID  :: Object o => NewObject o -> m ()
+  marshalArray  :: ByteString              -> m ()
+  marshalFD     :: Fd                      -> m ()
 
 -- | A monad providing an environment for reading a fixed number of arguments of various types.
 --
 -- For libwayland, the arguments are read from wl_arguments. It is considered a programmer error to read more arguments
 -- than expected by a request or different argument types than the ones specified.
-class Monad m => ArgumentDemarshaller m where
-  demarshalInt         :: m Int
-  demarshalUInt        :: m Word
-  demarshalFixed       :: m Float
-  demarshalString      :: m String
-  demarshalMaybeString :: m (Maybe String)
-  demarshalObject      :: Object o => m o
-  demarshalMaybeObject :: Object o => m (Maybe o)
-  demarshalNewID       :: Object o => m (NewObject o)
-  demarshalArray       :: m ByteString
-  demarshalFD          :: m Fd
+class MonadError String m => ArgumentDemarshaller m where
+  demarshalInt    :: m Int32
+  demarshalUInt   :: m Word32
+  demarshalFixed  :: m Float
+  demarshalString :: m (Maybe String)
+  demarshalObject :: m (Maybe AnyObject)
+  demarshalNewID  :: Object o => m (NewObject o)
+  demarshalArray  :: m ByteString
+  demarshalFD     :: m Fd
+
+-- | A type that can be marshalled or demarshalled in the corresponding monad.
+class Marshallable t where
+  marshal   :: ArgumentMarshaller m   => t -> m ()
+  demarshal :: ArgumentDemarshaller m => m t
 
 -- | An opaque handle to a Wayland object.
 --
@@ -187,8 +191,8 @@ newtype ArgumentWriter r a = ArgumentWriter { runArgumentWriter :: StateT Argume
   deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO)
 
 -- | Monad used for reading arguments from a wl_argument buffer.
-newtype ArgumentReader a = ArgumentReader { runArgumentReader :: StateT ArgumentIterator (ReaderT Client IO) a }
-  deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO, MonadReader Client)
+newtype ArgumentReader a = ArgumentReader { runArgumentReader :: ExceptT String (StateT ArgumentIterator (ReaderT Client IO)) a }
+  deriving (Functor, Applicative, Monad, MonadState ArgumentIterator, MonadIO, MonadError String, MonadReader Client)
 
 makeLenses ''ObjectCache
 
@@ -210,6 +214,52 @@ instance Show (NewObject o) where
 instance Eq (NewObject o) where
   a == b = newObject a == newObject b
 
+instance Marshallable Int32 where
+  marshal   = marshalInt
+  demarshal = demarshalInt
+
+instance Marshallable Word32 where
+  marshal   = marshalUInt
+  demarshal = demarshalUInt
+
+instance Marshallable Float where
+  marshal   = marshalFixed
+  demarshal = demarshalFixed
+
+instance Marshallable String where
+  marshal   = marshalString . Just
+  demarshal = do str <- demarshalString
+                 case str of
+                   Just s  -> pure s
+                   Nothing -> throwError "Expected string, got <null>"
+
+instance Marshallable (Maybe String) where
+  marshal   = marshalString
+  demarshal = demarshalString
+
+instance Marshallable AnyObject where
+  marshal   = marshalObject . Just
+  demarshal = do obj <- demarshalObject
+                 case obj of
+                   Just o  -> pure o
+                   Nothing -> throwError "Expected object, got <null>"
+
+instance Marshallable (Maybe AnyObject) where
+  marshal   = marshalObject
+  demarshal = demarshalObject
+
+instance Object o => Marshallable (NewObject o) where
+  marshal   = marshalNewID
+  demarshal = demarshalNewID
+
+instance Marshallable ByteString where
+  marshal   = marshalArray
+  demarshal = demarshalArray
+
+instance Marshallable Fd where
+  marshal   = marshalFD
+  demarshal = demarshalFD
+
 -- | Create a handle to an object that has yet to be created.
 createNewObject :: Client -> Word32 -> IO (NewObject o)
 createNewObject client objID = do
@@ -241,13 +291,13 @@ destroyObjectCache c = do
 -- | Get the underlying Wayland resource wrapped by a typed object.
 --
 -- This function may raise an error if the underlying resource is no longer alive.
-unwrapResource :: Object o => o -> IO WLResource
-unwrapResource o = resolveHandle (objHandle (toAny o))
+unwrapResource :: AnyObject -> IO WLResource
+unwrapResource o = resolveHandle (objHandle o)
 
 -- | Get the typed object wrapping a Wayland resource.
 --
 -- The object wrapper is stored as a StablePtr in the resource's userdata.
-wrapResource :: Object o => WLResource -> IO o
+wrapResource :: WLResource -> IO AnyObject
 wrapResource o = do
   objPtr <- castPtrToStablePtr <$> wlResourceGetUserData o
   deRefStablePtr objPtr
@@ -267,7 +317,8 @@ destroyResource res = do
 --
 -- This not only creates the object but also attaches a dispatch function to it and updates the destroy callback.
 createResource
-  :: forall o destroyMsg. Object o
+  :: forall o destroyMsg
+  . Object o
   => MessageClass destroyMsg
   => (Message -> IO ()) -- ^ Message handler used for dispatching object requests and the destroy hook.
   -> NewObject o        -- ^ Handle describing the object to be created
@@ -284,13 +335,13 @@ createResource handler newObj destroyHook = do
                     client <- unwrapClient (newClient newObj)
                     res <- wlResourceCreate client (typeInterface typeInfo) (fromIntegral version) (newID newObj)
                     handle <- createHandle res
-                    let obj = fromAny $ AnyObject { objHandle      = handle
-                                                  , objDestroyHook = handler . Message . destroyHook . fromAny
-                                                  }
+                    let obj = AnyObject { objHandle      = handle
+                                        , objDestroyHook = handler . Message . destroyHook . fromAny
+                                        }
                     objPtr <- newStablePtr obj
                     wlResourceSetDispatcher res (typeDispatchFunc typeInfo) nullPtr (castStablePtrToPtr objPtr) destroyFunc
-                    writeIORef (newObject newObj) (Just obj)
-                    pure obj
+                    writeIORef (newObject newObj) (Just (fromAny obj))
+                    pure (fromAny obj)
 
 -- | Send an event for a typed object.
 --
@@ -298,7 +349,7 @@ createResource handler newObj destroyHook = do
 sendResourceEvent :: forall o. Object o => o -> ObjectEvent o -> IO ()
 sendResourceEvent o e = do
   let paramCount = length $ msgArguments (eventSignature (Proxy :: Proxy o) e)
-  res <- unwrapResource o
+  res <- unwrapResource (toAny o)
   allocaArray0 paramCount $ \buffer ->
     runContT (runStateT (runArgumentWriter (marshalEvent (Proxy :: Proxy o) e)) (ArgumentIterator buffer)) $ \(opcode, _) ->
       wlResourcePostEventArray res (fromIntegral opcode) buffer
@@ -306,12 +357,24 @@ sendResourceEvent o e = do
 -- | Request handler for a typed object.
 --
 -- This provides a WLDispatcherFunc for an object type.
-dispatchResourceRequest :: forall o. Object o => Proxy o -> (Message -> IO ()) -> Ptr () -> WLResource -> Word32 -> Ptr WLMessage -> Ptr WLArgument -> IO CInt
+dispatchResourceRequest
+  :: forall o
+  . Object o
+  => Proxy o
+  -> (Message -> IO ())
+  -> Ptr ()
+  -> WLResource
+  -> Word32
+  -> Ptr WLMessage
+  -> Ptr WLArgument
+  -> IO CInt
 dispatchResourceRequest _ handler _ res opcode _ args = do
-  obj :: o <- wrapResource res
+  obj :: o <- fromAny <$> wrapResource res
   client <- wlResourceGetClient res >>= wrapClient
-  (req, _) <- runReaderT (runStateT (runArgumentReader (demarshalRequest obj (fromIntegral opcode))) (ArgumentIterator args)) client
-  handler $ Message req
+  (req, _) <- runReaderT (runStateT (runExceptT (runArgumentReader (demarshalRequest obj (fromIntegral opcode)))) (ArgumentIterator args)) client
+  case req of
+    Left err -> putStrLn $ "Received invalid request: " ++ err
+    Right r  -> handler $ Message r
   pure 0
 
 -- | Resolve a type information for an object type.
@@ -360,30 +423,28 @@ liftCont = ArgumentWriter . lift . ContT
 instance ArgumentMarshaller (ArgumentWriter r) where
   marshalInt v = do
     arg <- advanceIterator
-    liftIO $ wlArgumentPokeInt arg (fromIntegral v)
+    liftIO $ wlArgumentPokeInt arg v
   marshalUInt v = do
     arg <- advanceIterator
-    liftIO $ wlArgumentPokeUInt arg (fromIntegral v)
+    liftIO $ wlArgumentPokeUInt arg v
   marshalFixed v = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeFixed arg (WLFixed (round (v * 256)))
   marshalFD (Fd v) = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeFD arg (fromIntegral v)
-  marshalString v = do
+  marshalString (Just v) = do
     arg <- advanceIterator
     str <- liftCont $ withCString v
     liftIO $ wlArgumentPokeString arg str
-  marshalMaybeString (Just v) = marshalString v
-  marshalMaybeString Nothing = do
+  marshalString Nothing = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeString arg nullPtr
-  marshalObject v = do
+  marshalObject (Just v) = do
     arg <- advanceIterator
     obj <- liftIO $ unwrapResource v
     liftIO $ wlArgumentPokeObject arg obj
-  marshalMaybeObject (Just v) = marshalObject v
-  marshalMaybeObject Nothing = do
+  marshalObject Nothing = do
     arg <- advanceIterator
     liftIO $ wlArgumentPokeObject arg (WLResource nullPtr)
   marshalNewID v = do
@@ -399,20 +460,14 @@ instance ArgumentMarshaller (ArgumentWriter r) where
     liftIO $ wlArgumentPokeArray arg arr
 
 instance ArgumentDemarshaller ArgumentReader where
-  demarshalInt    = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekInt)
-  demarshalUInt   = fromIntegral   <$> (advanceIterator >>= liftIO . wlArgumentPeekUInt)
+  demarshalInt    = advanceIterator >>= liftIO . wlArgumentPeekInt
+  demarshalUInt   = advanceIterator >>= liftIO . wlArgumentPeekUInt
   demarshalFixed  = wlFixedToFloat <$> (advanceIterator >>= liftIO . wlArgumentPeekFixed)
   demarshalString = do
     ptr <- advanceIterator >>= liftIO . wlArgumentPeekString
-    liftIO $ peekCString ptr
-  demarshalMaybeString = do
-    ptr <- advanceIterator >>= liftIO . wlArgumentPeekString
     if ptr == nullPtr then pure Nothing else Just <$> liftIO (peekCString ptr)
   demarshalObject = do
     ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject
-    liftIO $ wrapResource ptr
-  demarshalMaybeObject = do
-    ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject
     if ptr == WLResource nullPtr then pure Nothing else Just <$> liftIO (wrapResource ptr)
   demarshalNewID = do
     objID <- advanceIterator >>= liftIO . wlArgumentPeekNewID