diff options
Diffstat (limited to 'protocols/codegen/Wayland/CodeGen/CodeGen.hs')
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/CodeGen.hs | 137 |
1 files changed, 116 insertions, 21 deletions
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 () |