wip codegen

1 files changed, 88 insertions, 0 deletions

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'