diff options
Diffstat (limited to 'protocols/codegen')
| -rw-r--r-- | protocols/codegen/Main.hs | 9 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/BuildGen.hs | 1 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/CodeGen.hs | 218 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Types.hs | 26 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Utils.hs | 13 |
5 files changed, 150 insertions, 117 deletions
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 |