diff options
Diffstat (limited to 'protocols/codegen/Wayland/CodeGen')
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/BuildGen.hs | 46 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/CodeGen.hs | 293 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Parser.hs | 39 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Types.hs | 75 | ||||
| -rw-r--r-- | protocols/codegen/Wayland/CodeGen/Utils.hs | 88 |
5 files changed, 505 insertions, 36 deletions
diff --git a/protocols/codegen/Wayland/CodeGen/BuildGen.hs b/protocols/codegen/Wayland/CodeGen/BuildGen.hs new file mode 100644 index 0000000..42d4b1d --- /dev/null +++ b/protocols/codegen/Wayland/CodeGen/BuildGen.hs @@ -0,0 +1,46 @@ +module Wayland.CodeGen.BuildGen + ( generateBuild + ) where + +import Wayland.CodeGen.Types +import Wayland.CodeGen.Utils + +data ModuleInfo + = ModuleInfo { modProtocol :: !Protocol + , modInterface :: !InterfaceDesc + } + +generateBuild :: [Protocol] -> String +generateBuild protocols = unlines ([ "cabal-version: 3.0" + , "name: highway-protocols" + , "version: 1.0.0" + , "synopsis: Generated bindings for some Wayland protocols." + , "build-type: Simple" + , "" + , "common warnings" + , " ghc-options: -Wall -Wno-unused-imports -Wno-dodgy-exports" + , "" + , "library" + , " import: warnings" + , " build-depends: base," + , " hashable," + , " bytestring," + , " highway-wayland" + , " default-language: Haskell2010" ] + ++ exposedModules (collectModules protocols)) + where exposedModules [] = [] + exposedModules [m] = [" exposed-modules: " ++ formatModule m] + exposedModules (m:ms) = (" exposed-modules: " ++ formatModule m ++ ",") : exposedModules' ms + exposedModules' [m] = [" " ++ formatModule m] + exposedModules' (m:ms) = (" " ++ formatModule m ++ ",") : exposedModules' ms + exposedModules' [] = [] + +formatModule :: ModuleInfo -> String +formatModule m = fullModule (modProtocol m) (modInterface m) + +collectModules :: [Protocol] -> [ModuleInfo] +collectModules = concatMap singleProtocol + where singleProtocol p = fmap (singleInterface p) (protInterfaces p) + singleInterface p i = ModuleInfo { modProtocol = p + , modInterface = i + } diff --git a/protocols/codegen/Wayland/CodeGen/CodeGen.hs b/protocols/codegen/Wayland/CodeGen/CodeGen.hs new file mode 100644 index 0000000..2fea7c6 --- /dev/null +++ b/protocols/codegen/Wayland/CodeGen/CodeGen.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wayland.CodeGen.CodeGen + ( generateInterface + , generateInterfaceBoot + ) where + +-- TODO: Documentation + +import Wayland.CodeGen.Types +import Wayland.CodeGen.Utils +import Control.Monad.State.Strict (State, runState) +import Lens.Micro.TH (makeLenses) +import Data.List (intercalate, sort, isPrefixOf) +import Lens.Micro.Mtl ((%=)) +import Data.Functor (($>)) +import Control.Monad.Reader (ReaderT (..), asks) +import Data.Map ((!)) +import qualified Data.Map as M + +newtype Declaration = Declaration { declLines :: [String] } +data Import = Import { imModule :: !String + , imSource :: !Bool + } + deriving (Show, Eq) + +data GeneratorState + = GeneratorState { _stateImports :: ![Import] + , _stateExports :: ![String] + , _stateExtensions :: ![String] + , _stateDecls :: ![Declaration] + } + +data GeneratorConfig + = GeneratorConfig { genModules :: !FlatModules + , genProtocol :: !TypedProtocol + , genInterface :: !InterfaceDesc + , genTypes :: !TypeInfo + } + +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 + +generateInterfaceBoot :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String +generateInterfaceBoot flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emitBoot + +generate :: GeneratorConfig -> Generator () -> String +generate cfg g = transform $ runState (runReaderT g cfg) initialState + where initialState = GeneratorState { _stateImports = [] + , _stateExports = [] + , _stateExtensions = [] + , _stateDecls = [] + } + transform (_, state) = undecls $ [ extensionDecl state, moduleDecl state, importDecl state ] ++ _stateDecls state + extensionDecl s = Declaration $ sort $ fmap formatExtension (_stateExtensions s) + moduleDecl s = Declaration [ "module " ++ genFullModule cfg ++ " (" ++ intercalate ", " (_stateExports s) ++ ") where" ] + importDecl s = Declaration $ sort $ fmap formatImport (_stateImports s) + undecls decls = intercalate "\n" $ unlines . declLines <$> filter (not . null . declLines) decls + formatExtension e = "{-# LANGUAGE " ++ e ++ " #-}" + formatImport i = "import " ++ (if imSource i then "{-# SOURCE #-} " else "") ++ "qualified " ++ imModule i + +genFullModule :: GeneratorConfig -> String +genFullModule cfg = fullModule (genProtocol cfg) (genInterface cfg) + +emitDecl :: [String] -> Generator () +emitDecl c = stateDecls %= (++ [ Declaration c ]) + +emitImport :: Import -> Generator () +emitImport i = stateImports %= \is -> if i `elem` is then is else i:is + +emitExport :: String -> Generator () +emitExport e = stateExports %= (e:) + +emitExtension :: String -> Generator () +emitExtension e = stateExtensions %= (e:) + +resolve :: String -> String -> Generator String +resolve m e = do + this <- asks genFullModule + if this == m + then pure e + else emitImport (Import m ("Wayland.Protocols." `isPrefixOf` m)) $> m ++ "." ++ e + +resolveInterface :: Maybe String -> String -> Generator String +resolveInterface (Just name) e = do modules <- asks genModules + let (p, i) = modules ! name + resolve (fullModule p (fst i)) e +resolveInterface Nothing e = pure e + +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' + resolveQualified (i, _:e') = do modules <- asks genModules + resolveInterface (Just i) $ typeEnums (snd (snd (modules ! i))) ! e' + +resolveArgument :: ArgumentDesc -> Generator String +resolveArgument a = case argType a of + ArgumentInt -> maybe (pure "Int") resolveEnum (argEnum a) + ArgumentUInt -> maybe (pure "Word") resolveEnum (argEnum a) + ArgumentFixed -> pure "Float" + 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" + ArgumentObject -> do obj <- resolveInterface (argInterface a) "Object" + pure $ if argAllowNull a then "(Maybe " ++ obj ++ ")" else obj + +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 + 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 + emitDecl [ "data " ++ name + , "instance Show " ++ name + , "instance Eq " ++ name ] + emitExport name + mapM_ emitEnumBoot (ifEnums i) + +emit :: Generator () +emit = do + anyObject <- resolve "Wayland.Server" "AnyObject" + hashable <- resolve "Data.Hashable" "Hashable" + objectClass <- resolve "Wayland.Server" "Object" + i <- asks genInterface + emitExtension "GeneralizedNewtypeDeriving" + emitExtension "EmptyDataDeriving" + emitDecl [ "newtype Object = Object " ++ anyObject + , " deriving (Show, Eq, Ord, " ++ hashable ++ ")" ] + emitExport "Object" + mapM_ (emitMessageDesc requestDescName) (ifRequests i) + mapM_ (emitMessageDesc eventDescName) (ifEvents i) + emitInterfaceDesc + emitRequests (ifRequests i) + emitEvents (ifEvents i) + mapM_ emitEnum (ifEnums i) + asks (typeRequestArgs . genTypes) >>= mapM_ emitArguments + asks (typeEventArgs . genTypes) >>= mapM_ emitArguments + 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 + +requestDescName :: MessageDesc -> String +requestDescName m = "req" ++ pascalCase (msgName m) + +eventDescName :: MessageDesc -> String +eventDescName m = "ev" ++ pascalCase (msgName m) + +emitMessageDesc :: (MessageDesc -> String) -> MessageDesc -> Generator () +emitMessageDesc name m = do + let argumentNullability True = resolve "Wayland.Server" "Nullable" + argumentNullability False = resolve "Wayland.Server" "NotNull" + let argumentType :: ArgumentDesc -> Generator String + argumentType a = case argType a of + ArgumentInt -> resolve "Wayland.Server" "ArgumentInt" + ArgumentUInt -> resolve "Wayland.Server" "ArgumentUInt" + ArgumentFixed -> resolve "Wayland.Server" "ArgumentFixed" + ArgumentArray -> resolve "Wayland.Server" "ArgumentArray" + ArgumentFD -> resolve "Wayland.Server" "ArgumentFD" + ArgumentString -> do aType <- resolve "Wayland.Server" "ArgumentString" + aNullability <- argumentNullability (argAllowNull a) + pure $ aType ++ " " ++ aNullability + ArgumentObject -> do aType <- resolve "Wayland.Server" "ArgumentObject" + aIface <- resolveInterface (argInterface a) "interface" + aNullability <- argumentNullability (argAllowNull a) + pure $ aType ++ " " ++ aNullability ++ " " ++ aIface + ArgumentNewID -> do aType <- resolve "Wayland.Server" "ArgumentNewID" + aIface <- resolveInterface (argInterface a) "interface" + pure $ aType ++ " " ++ aIface + messageDesc <- resolve "Wayland.Server" "MessageDesc" + msgName' <- resolve "Wayland.Server" "msgName" + msgArguments' <- resolve "Wayland.Server" "msgArguments" + msgSince' <- resolve "Wayland.Server" "msgSince" + msgIsDestructor' <- resolve "Wayland.Server" "msgIsDestructor" + arguments <- mapM argumentType (msgArguments m) + emitDecl [ name m ++ " :: " ++ messageDesc + , name m ++ " =" + , " " ++ messageDesc + , " { " ++ msgName' ++ " = " ++ escapeStr (msgName m) + , " , " ++ msgArguments' ++ " = [" ++ intercalate ", " arguments ++ "]" + , " , " ++ msgSince' ++ " = " ++ show (msgSince m) + , " , " ++ msgIsDestructor' ++ " = " ++ show (msgType m == MessageDestructor) + , " }" + ] + +emitInterfaceDesc :: Generator () +emitInterfaceDesc = do + interfaceDesc <- resolve "Wayland.Server" "InterfaceDesc" + ifName' <- resolve "Wayland.Server" "ifName" + ifVersion' <- resolve "Wayland.Server" "ifVersion" + ifRequests' <- resolve "Wayland.Server" "ifRequests" + ifEvents' <- resolve "Wayland.Server" "ifEvents" + i <- asks genInterface + emitDecl [ "interface :: " ++ interfaceDesc + , "interface =" + , " " ++ interfaceDesc + , " { " ++ ifName' ++ " = " ++ escapeStr (ifName i) + , " , " ++ ifVersion' ++ " = " ++ show (ifVersion i) + , " , " ++ ifRequests' ++ " = [" ++ intercalate ", " (requestDescName <$> ifRequests i) ++ "]" + , " , " ++ ifEvents' ++ " = [" ++ intercalate ", " (eventDescName <$> ifEvents i) ++ "]" + , " }" ] + emitExport "interface" + +emitRequests :: [MessageDesc] -> Generator () +emitRequests ms = emitMessages ms typeRequestArgs formatConstructor "Request" + where formatConstructor m = "Req" ++ pascalCase (msgName m) ++ " Object" + +emitEvents :: [MessageDesc] -> Generator () +emitEvents ms = emitMessages ms typeEventArgs formatConstructor "Event" + where formatConstructor m = "Ev" ++ pascalCase (msgName m) + +emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentMode) -> (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 constructor m = (++) (formatConstructor m) <$> constructorArg (args ! msgName m) + constructors <- mapM constructor ms + emitDecl $ [ "data " ++ type' ] + ++ dataConstructors constructors + ++ [ " deriving (" ++ typeable ++ ", Show, Eq)" ] + emitExport $ type' ++ "(..)" + emitDecl [ "instance " ++ messageClass ++ " " ++ type' + , "instance " ++ typeClass ++ " " ++ type' ] + +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) + emitDecl ([ "data " ++ name ] + ++ constructors ++ + [ " deriving (Show, Eq)" ]) + emitExport $ name ++ "(..)" + +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 + resolvedArgs <- mapM resolveArgument args + emitDecl ([ "data " ++ name + , " = " ++ name ] + ++ formatArgs (zip args resolvedArgs) ++ + [ " }" + , " deriving (Show, Eq)" ]) + emitExport $ name ++ "(..)" + +dataConstructors :: [String] -> [String] +dataConstructors (c:cs) = (" = " ++ c) : fmap (" | " ++) cs +dataConstructors [] = [] + +escapeStr :: String -> String +escapeStr str = "\"" ++ escapeInner str ++ "\"" + where escapeInner ('\"':xs) = "\\\"" ++ escapeInner xs + escapeInner ('\\':xs) = "\\\\" ++ escapeInner xs + escapeInner ('\n':xs) = "\\n" ++ escapeInner xs + escapeInner (x :xs) = x : escapeInner xs + escapeInner [] = [] diff --git a/protocols/codegen/Wayland/CodeGen/Parser.hs b/protocols/codegen/Wayland/CodeGen/Parser.hs index 63ba2c4..e2f6c23 100644 --- a/protocols/codegen/Wayland/CodeGen/Parser.hs +++ b/protocols/codegen/Wayland/CodeGen/Parser.hs @@ -2,6 +2,7 @@ module Wayland.CodeGen.Parser ( parseProtocolSpec ) where +import Data.Maybe (fromMaybe) import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc) import Text.Read (readEither) import Wayland.CodeGen.Types @@ -34,7 +35,7 @@ processInterface :: Element -> Either String InterfaceDesc processInterface el = do name <- requireAttr "name" el version <- requireAttr "version" el >>= readEither - description <- traverse processDescription (filterChildName (matchName "description") el) + 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) @@ -49,14 +50,14 @@ processInterface el = do processEnum :: Element -> Either String EnumDesc processEnum el = do name <- requireAttr "name" el - description <- traverse processDescription (filterChildName (matchName "description") el) - since <- traverse readEither (findAttrBy (matchName "since") el) - bitfield <- traverse readBool (findAttrBy (matchName "bitfield") el) + description <- mapM processDescription (filterChildName (matchName "description") el) + since <- mapM readEither (findAttrBy (matchName "since") el) + bitfield <- mapM readBool (findAttrBy (matchName "bitfield") el) entries <- mapM processEntry (filterChildrenName (matchName "entry") el) pure $ EnumDesc { enumName = name , enumDescription = description - , enumSince = since - , enumBitfield = bitfield + , enumSince = fromMaybe 1 since + , enumBitfield = fromMaybe False bitfield , enumEntries = entries } @@ -64,30 +65,30 @@ processEntry :: Element -> Either String EntryDesc processEntry el = do name <- requireAttr "name" el value <- requireAttr "value" el >>= readEither - description <- traverse processDescription (filterChildName (matchName "description") el) - since <- traverse readEither (findAttrBy (matchName "since") el) - deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el) + description <- mapM processDescription (filterChildName (matchName "description") el) + since <- mapM readEither (findAttrBy (matchName "since") el) + deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el) let summary = findAttrBy (matchName "summary") el pure $ EntryDesc { entryName = name , entryValue = value , entryDescription = description , entrySummary = summary - , entrySince = since + , entrySince = fromMaybe 1 since , entryDeprecatedSince = deprecatedSince } processMessage :: Element -> Either String MessageDesc processMessage el = do name <- requireAttr "name" el - description <- traverse processDescription (filterChildName (matchName "description") el) - type' <- traverse readMessageType (findAttrBy (matchName "type") el) - since <- traverse readEither (findAttrBy (matchName "since") el) - deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el) + description <- mapM processDescription (filterChildName (matchName "description") el) + type' <- mapM readMessageType (findAttrBy (matchName "type") el) + since <- mapM readEither (findAttrBy (matchName "since") el) + deprecatedSince <- mapM readEither (findAttrBy (matchName "deprecated-since") el) arguments <- mapM processArgument (filterChildrenName (matchName "arg") el) pure $ MessageDesc { msgName = name , msgDescription = description - , msgType = type' - , msgSince = since + , msgType = fromMaybe MessageNormal type' + , msgSince = fromMaybe 1 since , msgDeprecatedSince = deprecatedSince , msgArguments = arguments } @@ -96,8 +97,8 @@ processArgument :: Element -> Either String ArgumentDesc processArgument el = do name <- requireAttr "name" el type' <- requireAttr "type" el >>= readArgumentType - description <- traverse processDescription (filterChildName (matchName "description") el) - allowNull <- traverse readBool (findAttrBy (matchName "allow-null") el) + description <- mapM processDescription (filterChildName (matchName "description") el) + allowNull <- mapM readBool (findAttrBy (matchName "allow-null") el) let summary = findAttrBy (matchName "summary") el let interface = findAttrBy (matchName "interface") el let enum = findAttrBy (matchName "enum") el @@ -106,8 +107,8 @@ processArgument el = do , argDescription = description , argSummary = summary , argInterface = interface - , argAllowNull = allowNull , argEnum = enum + , argAllowNull = fromMaybe False allowNull } requireAttr :: String -> Element -> Either String String diff --git a/protocols/codegen/Wayland/CodeGen/Types.hs b/protocols/codegen/Wayland/CodeGen/Types.hs index b783a7c..1a1d17e 100644 --- a/protocols/codegen/Wayland/CodeGen/Types.hs +++ b/protocols/codegen/Wayland/CodeGen/Types.hs @@ -1,5 +1,8 @@ module Wayland.CodeGen.Types - ( Protocol(..) + ( ProtocolT(..) + , Protocol + , TypedProtocol + , TypedInterfaceDesc , InterfaceDesc(..) , EnumDesc(..) , EntryDesc(..) @@ -7,17 +10,29 @@ module Wayland.CodeGen.Types , MessageType(..) , ArgumentDesc(..) , ArgumentType(..) + , ArgumentMode(..) , Description(..) + , TypeInfo(..) + , emptyTypeInfo + , isTypeFree ) where +import qualified Data.Map as M -data Protocol +data ProtocolT i = Protocol { protName :: !String , protCopyright :: !(Maybe String) , protDescription :: !(Maybe Description) - , protInterfaces :: ![InterfaceDesc] + , protInterfaces :: ![i] } deriving Show +type Protocol = ProtocolT InterfaceDesc + +-- Protocol with type names resolved (avoiding possible name clashes within an interface). +type TypedProtocol = ProtocolT TypedInterfaceDesc + +type TypedInterfaceDesc = (InterfaceDesc, TypeInfo) + data InterfaceDesc = InterfaceDesc { ifName :: !String , ifVersion :: !Int @@ -31,8 +46,8 @@ data InterfaceDesc data EnumDesc = EnumDesc { enumName :: !String , enumDescription :: !(Maybe Description) - , enumSince :: !(Maybe Int) - , enumBitfield :: !(Maybe Bool) + , enumSince :: !Int + , enumBitfield :: !Bool , enumEntries :: ![EntryDesc] } deriving Show @@ -42,7 +57,7 @@ data EntryDesc , entryValue :: !Int , entryDescription :: !(Maybe Description) , entrySummary :: !(Maybe String) - , entrySince :: !(Maybe Int) + , entrySince :: !Int , entryDeprecatedSince :: !(Maybe Int) } deriving Show @@ -50,8 +65,8 @@ data EntryDesc data MessageDesc = MessageDesc { msgName :: !String , msgDescription :: !(Maybe Description) - , msgType :: !(Maybe MessageType) - , msgSince :: !(Maybe Int) + , msgType :: !MessageType + , msgSince :: !Int , msgDeprecatedSince :: !(Maybe Int) , msgArguments :: ![ArgumentDesc] } @@ -60,17 +75,17 @@ data MessageDesc data MessageType = MessageNormal | MessageDestructor - deriving Show + deriving (Show, Eq) data ArgumentDesc = ArgumentDesc { argName :: !String - , argType :: !ArgumentType - , argDescription :: !(Maybe Description) - , argSummary :: !(Maybe String) - , argInterface :: !(Maybe String) - , argAllowNull :: !(Maybe Bool) - , argEnum :: !(Maybe String) - } + , argType :: !ArgumentType + , argDescription :: !(Maybe Description) + , argSummary :: !(Maybe String) + , argInterface :: !(Maybe String) + , argEnum :: !(Maybe String) + , argAllowNull :: !Bool + } deriving Show data ArgumentType @@ -82,10 +97,36 @@ data ArgumentType | ArgumentFD | ArgumentNewID | ArgumentObject - deriving Show + deriving (Show, Eq) data Description = Description { descSummary :: !String , descBody :: !String } deriving Show + +data ArgumentMode + = ArgumentModeNone + | ArgumentModeSingle ArgumentDesc + | ArgumentModeRecord [ArgumentDesc] String + deriving Show + +data TypeInfo + = TypeInfo { typeRequestArgs :: !(M.Map String ArgumentMode) + , typeEventArgs :: !(M.Map String ArgumentMode) + , typeEnums :: !(M.Map String String) + } + deriving Show + +emptyTypeInfo :: TypeInfo +emptyTypeInfo = TypeInfo { typeRequestArgs = M.empty + , typeEventArgs = M.empty + , typeEnums = 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' + argMatches _ _ = False diff --git a/protocols/codegen/Wayland/CodeGen/Utils.hs b/protocols/codegen/Wayland/CodeGen/Utils.hs new file mode 100644 index 0000000..fa04286 --- /dev/null +++ b/protocols/codegen/Wayland/CodeGen/Utils.hs @@ -0,0 +1,88 @@ +module Wayland.CodeGen.Utils + ( pascalCase + , camelCase + , recordField + , protocolModule + , interfaceModule + , fullModule + , FlatModules + , flattenModules + , resolveTypes + ) where + +import Data.Char (toUpper, toLower) +import Wayland.CodeGen.Types +import qualified Data.Map as M +import Control.Monad.State.Strict (State, runState, gets, modify) +import Data.Functor (($>)) + +type FlatModules = M.Map String (TypedProtocol, TypedInterfaceDesc) + +pascalCase :: String -> String +pascalCase (c:cs) = toUpper c : camelCase cs +pascalCase [] = [] + +camelCase :: String -> String +camelCase ('_':cs) = pascalCase cs +camelCase (c :cs) = c : camelCase cs +camelCase [] = [] + +recordField :: String -> String -> String +recordField name field = applyFirst toLower name ++ applyFirst toUpper field + where applyFirst _ [] = [] + applyFirst f (x:xs) = f x : xs + +protocolModule :: ProtocolT i -> String +protocolModule = fromName . protName + where fromName "wayland" = "Core" + fromName name = pascalCase name + +interfaceModule :: InterfaceDesc -> String +interfaceModule = pascalCase . ifName + +fullModule :: ProtocolT i -> InterfaceDesc -> String +fullModule p i = "Wayland.Protocols." ++ protocolModule p ++ "." ++ interfaceModule i + +flattenModules :: [TypedProtocol] -> FlatModules +flattenModules protocols = M.unions $ fmap flattenProtocol protocols + where flattenProtocol p = M.fromList $ fmap (flattenInterface p) (protInterfaces p) + flattenInterface p i = (ifName (fst i), (p, i)) + +resolveTypes :: Protocol -> TypedProtocol +resolveTypes p = Protocol { protName = protName p + , protDescription = protDescription p + , protCopyright = protCopyright p + , protInterfaces = runInterface <$> protInterfaces p + } + where runInterface i = runState (resolveInterfaceTypes i $> i) emptyTypeInfo + +resolveInterfaceTypes :: InterfaceDesc -> State TypeInfo () +resolveInterfaceTypes i = do + let assignRequestArgs r a (TypeInfo requests events enums) = TypeInfo (M.insert r a requests) events enums + let assignEventArgs e a (TypeInfo requests events enums) = TypeInfo requests (M.insert e a events) enums + let assignEnumName e n (TypeInfo requests events enums) = TypeInfo requests events (M.insert e n enums) + let resolveAndAssign res ass = do x <- res; modify $ ass x + mapM_ (\m -> resolveAndAssign (resolveMessageType m) (assignEventArgs (msgName m))) (ifEvents i) + 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 m = case msgArguments m of + [] -> pure ArgumentModeNone + [a] -> pure $ ArgumentModeSingle a + as -> ArgumentModeRecord 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 + +getFreeTypeName :: String -> Maybe String -> State TypeInfo String +getFreeTypeName requested conflictSuffix = attemptRequested + where attemptName :: String -> State TypeInfo Bool + attemptName name = gets $ isTypeFree name + attemptRequested = attemptName requested >>= \s -> if s then pure requested else attemptSuffix + attemptSuffix = case conflictSuffix of + Just suffix -> let n = requested ++ suffix + in attemptName n >>= \s -> if s then pure n else attemptPrime n + Nothing -> attemptPrime requested + attemptPrime n = let n' = n ++ "'" + in attemptName n' >>= \s -> if s then pure n' else attemptPrime n' |