diff options
Diffstat (limited to 'protocols/codegen')
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/BuildGen.hs | 2 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/CodeGen.hs | 137 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Parser.hs | 9 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Types.hs | 1 |
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 |