From f4f93ad6e9289d499e1f4c6cf7f9581e622f2d26 Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Tue, 13 Aug 2024 22:13:06 +0200 Subject: impl codegen --- highway/Main.hs | 2 +- protocols/codegen/Wayland/CodeGen/BuildGen.hs | 2 +- protocols/codegen/Wayland/CodeGen/CodeGen.hs | 137 ++++++++++++++++++++++---- protocols/codegen/Wayland/CodeGen/Parser.hs | 9 +- protocols/codegen/Wayland/CodeGen/Types.hs | 1 + wayland/Wayland/Server/Object.hs | 63 ++++++++---- wayland/wayland.cabal | 1 + 7 files changed, 167 insertions(+), 48 deletions(-) diff --git a/highway/Main.hs b/highway/Main.hs index 8f6bcd6..481ec33 100644 --- a/highway/Main.hs +++ b/highway/Main.hs @@ -4,12 +4,12 @@ import Wayland.Server import Lens.Micro.TH (makeLenses) import Lens.Micro.Mtl ((%=), (<%=)) import Data.Data (Typeable) +import Data.Time (secondsToDiffTime) import Control.Monad (void, when) import Control.Monad.Trans (liftIO) import System.Posix.Signals (sigINT) import qualified Wayland.Protocols.Core.WlOutput as WlOutput import qualified Data.Map as M -import Data.Time (secondsToDiffTime) geometry :: WlOutput.Geometry geometry = WlOutput.Geometry { WlOutput.geometryX = 0 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 diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs index b56bbaf..b13e36f 100644 --- a/wayland/Wayland/Server/Object.hs +++ b/wayland/Wayland/Server/Object.hs @@ -41,6 +41,7 @@ import Data.Kind (Type) import Data.Hashable (Hashable(..)) import Data.IORef (readIORef, newIORef, IORef, writeIORef) import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable) +import Data.ByteString (ByteString, useAsCStringLen, packCStringLen) import Foreign import Foreign.C (withCString, peekCString, CInt) import Lens.Micro.Mtl (use, (%=), zoom) @@ -113,28 +114,32 @@ 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 () - marshalObject :: Object o => o -> m () - marshalNewID :: Object o => NewObject o -> m () - marshalArray :: Storable a => [a] -> m () - marshalFD :: Fd -> m () + 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 () -- | 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 - demarshalObject :: Object o => m o - demarshalNewID :: Object o => m (NewObject o) - demarshalArray :: Storable a => m [a] - demarshalFD :: m Fd + 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 -- | An opaque handle to a Wayland object. -- @@ -202,6 +207,9 @@ instance Show AnyObject where instance Show (NewObject o) where show o = "NewObject " ++ show (newClient o) ++ " " ++ show (newID o) +instance Eq (NewObject o) where + a == b = newObject a == newObject b + -- | Create a handle to an object that has yet to be created. createNewObject :: Client -> Word32 -> IO (NewObject o) createNewObject client objID = do @@ -366,19 +374,26 @@ instance ArgumentMarshaller (ArgumentWriter r) where arg <- advanceIterator str <- liftCont $ withCString v liftIO $ wlArgumentPokeString arg str + marshalMaybeString (Just v) = marshalString v + marshalMaybeString Nothing = do + arg <- advanceIterator + liftIO $ wlArgumentPokeString arg nullPtr marshalObject v = do arg <- advanceIterator obj <- liftIO $ unwrapResource v liftIO $ wlArgumentPokeObject arg obj + marshalMaybeObject (Just v) = marshalObject v + marshalMaybeObject Nothing = do + arg <- advanceIterator + liftIO $ wlArgumentPokeObject arg (WLResource nullPtr) marshalNewID v = do arg <- advanceIterator liftIO $ wlArgumentPokeNewID arg (newID v) marshalArray v = do arg <- advanceIterator - let len = fromIntegral $ length v * sizeOf (head v) - buf <- liftCont $ withArray v - arr <- liftCont $ with $ WLArray { arrSize = len - , arrAlloc = len + (buf, len) <- liftCont $ useAsCStringLen v + arr <- liftCont $ with $ WLArray { arrSize = fromIntegral len + , arrAlloc = fromIntegral len , arrData = castPtr buf } liftIO $ wlArgumentPokeArray arg arr @@ -390,9 +405,15 @@ instance ArgumentDemarshaller ArgumentReader where 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 client <- ask @@ -400,5 +421,5 @@ instance ArgumentDemarshaller ArgumentReader where demarshalArray = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekArray arr <- liftIO $ peek ptr - liftIO $ peekArray (fromIntegral (arrSize arr)) (castPtr (arrData arr)) + liftIO $ packCStringLen (castPtr (arrData arr), fromIntegral (arrSize arr)) demarshalFD = Fd . fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekFD) diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal index 9b08e2c..36fdb20 100644 --- a/wayland/wayland.cabal +++ b/wayland/wayland.cabal @@ -16,6 +16,7 @@ library microlens, microlens-mtl, microlens-th, + bytestring, time default-language: Haskell2010 exposed-modules: Wayland.Server -- cgit v1.3.1