impl codegen

4 files changed, 123 insertions, 26 deletions

diff --git a/protocols/codegen/Wayland/CodeGen/BuildGen.hs b/protocols/codegen/Wayland/CodeGen/BuildGen.hs
index 42d4b1d..4b6a4e8 100644
--- a/protocols/codegen/Wayland/CodeGen/BuildGen.hs
+++ b/protocols/codegen/Wayland/CodeGen/BuildGen.hs
@@ -18,7 +18,7 @@ generateBuild protocols = unlines ([ "cabal-version:      3.0"
                                    , "build-type:         Simple"
                                    , ""
                                    , "common warnings"
-                                   , "    ghc-options: -Wall -Wno-unused-imports -Wno-dodgy-exports"
+                                   , "    ghc-options: -Wall -Wno-unused-imports -Wno-dodgy-exports -Wno-overlapping-patterns"
                                    , ""
                                    , "library"
                                    , "    import:           warnings"
diff --git a/protocols/codegen/Wayland/CodeGen/CodeGen.hs b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
index 2fea7c6..517199a 100644
--- a/protocols/codegen/Wayland/CodeGen/CodeGen.hs
+++ b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
@@ -17,6 +17,7 @@ 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
@@ -107,7 +108,9 @@ resolveArgument a = case argType a of
                       ArgumentArray  -> resolve "Data.ByteString" "ByteString"
                       ArgumentFD     -> resolve "System.Posix.Types" "Fd"
                       ArgumentString -> pure $ if argAllowNull a then "(Maybe String)" else "String"
-                      ArgumentNewID  -> resolveInterface (argInterface a) "Object"
+                      ArgumentNewID  -> do obj <- resolveInterface (argInterface a) "Object"
+                                           newObj <- resolve "Wayland.Server" "NewObject"
+                                           pure $ "(" ++ newObj ++ " " ++ obj ++ ")"
                       ArgumentObject -> do obj <- resolveInterface (argInterface a) "Object"
                                            pure $ if argAllowNull a then "(Maybe " ++ obj ++ ")" else obj
 
@@ -128,7 +131,8 @@ emitBoot = do
   let emitEnumBoot e = do let name = enumTypes ! enumName e
                           emitDecl [ "data " ++ name
                                    , "instance Show " ++ name
-                                   , "instance Eq " ++ name ]
+                                   , "instance Eq " ++ name
+                                   , "instance Enum " ++ name ]
                           emitExport name
   mapM_ emitEnumBoot (ifEnums i)
 
@@ -138,6 +142,7 @@ emit = do
   hashable      <- resolve "Data.Hashable" "Hashable"
   objectClass   <- resolve "Wayland.Server" "Object"
   i             <- asks genInterface
+  types         <- asks genTypes
   emitExtension "GeneralizedNewtypeDeriving"
   emitExtension "EmptyDataDeriving"
   emitDecl [ "newtype Object = Object " ++ anyObject
@@ -147,22 +152,35 @@ emit = do
   mapM_ (emitMessageDesc eventDescName)   (ifEvents i)
   emitInterfaceDesc
   emitRequests (ifRequests i)
-  emitEvents   (ifEvents i)
+  emitEvents   (ifEvents   i)
   mapM_ emitEnum (ifEnums i)
-  asks (typeRequestArgs . genTypes) >>= mapM_ emitArguments
-  asks (typeEventArgs   . genTypes) >>= mapM_ emitArguments
+  mapM_ emitArguments (typeRequestArgs types)
+  mapM_ emitArguments (typeEventArgs   types)
   emitExtension "TypeFamilies"
-  emitDecl [ "instance " ++ objectClass ++ " Object where"
-           , "  type ObjectEvent Object = Event"
-           , "  type ObjectRequest Object = Request"
-           , "  toAny (Object o) = o"
-           , "  fromAny = Object"
-           , "  describeInterface _ = interface"
-           , "  demarshalRequest _ _ = undefined"
-           , "  marshalEvent _ _ = undefined"
-           , "  requestSignature _ _ = undefined"
-           , "  eventSignature _ _ = undefined" ]
-  -- TODO: Proper marshalling/demarshalling
+  let matchArgument m msgTypes = case msgTypes ! msgName m of
+                                   ArgumentModeNone       -> ""
+                                   ArgumentModeSingle _   -> " _"
+                                   ArgumentModeRecord _ _ -> " _"
+  let requestSignature m =
+        "  requestSignature _ (Req" ++ pascalCase (msgName m) ++ " _" ++ matchArgument m (typeRequestArgs types) ++ ") = req" ++ pascalCase (msgName m)
+  let eventSignature m =
+        "  eventSignature _ (Ev" ++ pascalCase (msgName m) ++ matchArgument m (typeEventArgs types) ++ ") = ev" ++ pascalCase (msgName m)
+  demarshalRequests <- concat <$> mapM demarshalRequest (ifRequests i)
+  marshalEvents     <- concat <$> mapM marshalEvent     (ifEvents   i)
+  emitDecl ([ "instance " ++ objectClass ++ " Object where"
+            , "  type ObjectEvent Object = Event"
+            , "  type ObjectRequest Object = Request"
+            , "  toAny (Object o) = o"
+            , "  fromAny = Object"
+            , "  describeInterface _ = interface" ]
+            ++ demarshalRequests ++
+            [ "  demarshalRequest _ _ = undefined" ]
+            ++ marshalEvents ++
+            [ "  marshalEvent _ _ = undefined" ]
+            ++ fmap requestSignature (ifRequests i) ++
+            [ "  requestSignature _ _ = undefined" ]
+            ++ fmap eventSignature (ifEvents i) ++
+            [ "  eventSignature _ _ = undefined" ])
 
 requestDescName :: MessageDesc -> String
 requestDescName m = "req" ++ pascalCase (msgName m)
@@ -225,13 +243,17 @@ emitInterfaceDesc = do
            , "    }" ]
   emitExport "interface"
 
+requestConstructor :: MessageDesc -> String
+requestConstructor m = "Req" ++ pascalCase (msgName m)
+
+eventConstructor :: MessageDesc -> String
+eventConstructor m = "Ev" ++ pascalCase (msgName m)
+
 emitRequests :: [MessageDesc] -> Generator ()
-emitRequests ms = emitMessages ms typeRequestArgs formatConstructor "Request"
-  where formatConstructor m = "Req" ++ pascalCase (msgName m) ++ " Object"
+emitRequests ms = emitMessages ms typeRequestArgs (\m -> requestConstructor m ++ " Object") "Request"
 
 emitEvents :: [MessageDesc] -> Generator ()
-emitEvents ms = emitMessages ms typeEventArgs formatConstructor "Event"
-  where formatConstructor m = "Ev" ++ pascalCase (msgName m)
+emitEvents ms = emitMessages ms typeEventArgs eventConstructor "Event"
 
 emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentMode) -> (MessageDesc -> String) -> String -> Generator ()
 emitMessages ms argTypes formatConstructor type' = do
@@ -252,17 +274,90 @@ emitMessages ms argTypes formatConstructor type' = do
   emitDecl [ "instance " ++ messageClass ++ " " ++ type'
            , "instance " ++ typeClass ++ " " ++ type' ]
 
+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"
+  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) ++ "'"
+                                  pure ([ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = do" ]
+                                        ++ fmap demarshal (zip vals as) ++
+                                        [ "    pure $ " ++ requestConstructor m ++ " o $ " ++ r ]
+                                        ++ formatArgs 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"
+  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"
+                                       , "    pure " ++ show (msgOpCode m) ]
+    ArgumentModeRecord as r -> do funcs <- mapM marshalFunc as
+                                  let apply (func, a) = "    " ++ func ++ " $ " ++ recordField r (camelCase (argName a)) ++ " x"
+                                  pure ([ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do" ]
+                                        ++ fmap apply (zip funcs as) ++
+                                        [ "    pure " ++ show (msgOpCode m) ])
+
 emitEnum :: EnumDesc -> Generator ()
 emitEnum e = do
   -- TODO: Handle bitsets
   types <- asks $ typeEnums . genTypes
   let name = types ! enumName e
   let constructorName entry = name ++ pascalCase (entryName entry)
-  let constructors = dataConstructors $ fmap constructorName (enumEntries e)
+  let constructorNames = fmap constructorName (enumEntries e)
+  let constructors = dataConstructors constructorNames
   emitDecl ([ "data " ++ name ]
             ++ 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)
 
 emitArguments :: ArgumentMode -> Generator ()
 emitArguments  ArgumentModeNone              = pure ()
diff --git a/protocols/codegen/Wayland/CodeGen/Parser.hs b/protocols/codegen/Wayland/CodeGen/Parser.hs
index e2f6c23..15afbb9 100644
--- a/protocols/codegen/Wayland/CodeGen/Parser.hs
+++ b/protocols/codegen/Wayland/CodeGen/Parser.hs
@@ -37,8 +37,8 @@ processInterface el = do
   version     <- requireAttr "version" el >>= readEither
   description <- mapM processDescription (filterChildName (matchName "description") el)
   enums       <- mapM processEnum (filterChildrenName (matchName "enum") el)
-  requests    <- mapM processMessage (filterChildrenName (matchName "request") el)
-  events      <- mapM processMessage (filterChildrenName (matchName "event") el)
+  requests    <- mapM processMessage (zip (filterChildrenName (matchName "request") el) [0..])
+  events      <- mapM processMessage (zip (filterChildrenName (matchName "event"  ) el) [0..])
   pure $ InterfaceDesc { ifName        = name
                        , ifVersion     = version
                        , ifDescription = description
@@ -77,8 +77,8 @@ processEntry el = do
                    , entryDeprecatedSince = deprecatedSince
                    }
 
-processMessage :: Element -> Either String MessageDesc
-processMessage el = do
+processMessage :: (Element, Int) -> Either String MessageDesc
+processMessage (el, opcode) = do
   name            <- requireAttr "name" el
   description     <- mapM processDescription (filterChildName (matchName "description") el)
   type'           <- mapM readMessageType (findAttrBy (matchName "type") el)
@@ -86,6 +86,7 @@ processMessage el = do
   deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el)
   arguments       <- mapM processArgument (filterChildrenName (matchName "arg") el)
   pure $ MessageDesc { msgName            = name
+                     , msgOpCode          = opcode
                      , msgDescription     = description
                      , msgType            = fromMaybe MessageNormal type'
                      , msgSince           = fromMaybe 1 since
diff --git a/protocols/codegen/Wayland/CodeGen/Types.hs b/protocols/codegen/Wayland/CodeGen/Types.hs
index 1a1d17e..5f2c232 100644
--- a/protocols/codegen/Wayland/CodeGen/Types.hs
+++ b/protocols/codegen/Wayland/CodeGen/Types.hs
@@ -64,6 +64,7 @@ data EntryDesc
 
 data MessageDesc
   = MessageDesc { msgName            :: !String
+                , msgOpCode          :: !Int
                 , msgDescription     :: !(Maybe Description)
                 , msgType            :: !MessageType
                 , msgSince           :: !Int