1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
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 ArgumentName
resolveMessageType m = case msgArguments m of
[] -> pure ArgumentNameNone
[a] -> pure $ ArgumentNameSingle a
as -> ArgumentNameRecord as <$> getFreeTypeName (pascalCase (msgName m)) 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
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'
|
