Skip to content

Commit 659dc0d

Browse files
svenpannesvenpanne
committed
Refactorings: Move API-specific things out of MangledRegistry. Cleanups.
1 parent 4253baf commit 659dc0d

File tree

2 files changed

+89
-71
lines changed

2 files changed

+89
-71
lines changed

‎RegistryProcessor/src/Main.hs‎

Lines changed: 60 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ main :: IO ()
1717
main = do
1818
[registryPath] <- E.getArgs
1919
let api = API "gl"
20-
res <- fmap parseRegistry $ readFile registryPath
20+
res <- parseRegistry toEnumType `fmap` readFile registryPath
2121
case res of
2222
Left msg -> SI.hPutStrLn SI.stderr msg
2323
Right registry -> do
@@ -106,28 +106,36 @@ printFunctions api registry sigMap = do
106106

107107
printExtensions :: API -> Registry -> IO ()
108108
printExtensions api registry = do
109-
-- only consider non-empty supported extensions/modifications for the given API
110-
let supportedExtensions =
111-
[ nameAndMods
112-
| ext <- extensions registry
113-
, api `supports` extensionSupported ext
114-
, nameAndMods@(_,(_:_)) <- [nameAndModifications api ext] ]
115-
CM.forM_ supportedExtensions $ \(n,mods) -> do
116-
let ("GL":vendor:extWords) = splitBy (== '_') (unExtensionName n)
117-
modSuff = concat (zipWith fixExtensionWord extWords [0 ..])
109+
CM.forM_ (supportedExtensions api registry) $ \(n,mods) -> do
110+
let modSuff = concat (zipWith fixExtensionWord (splitBy (== '_') (extensionNameName n)) [0 ..])
118111
profileAndModuleNameSuffix =
119112
if any isProfileDependent mods
120113
then [(ProfileName p, modSuff ++ capitalize p)
121114
| p <- ["core", "compatibility"] ]
122115
else [(ProfileName "core", modSuff)] -- the actual profile doesn't matter
123-
ext = L.intercalate "_" extWords
124116
comment = ["The <https://www.opengl.org/registry/specs/" ++
125-
fixRegistryPath (vendor ++ "/" ++ ext) ++ ".txt " ++
126-
vendor ++ "_" ++ ext ++ "> extension."]
117+
fixRegistryPath (extensionNameCategory n ++ "/" ++ extensionNameName n) ++ ".txt " ++
118+
extensionNameCategory n ++ "_" ++ extensionNameName n ++ "> extension."]
127119
CM.forM_ profileAndModuleNameSuffix $ \(prof, moduleNameSuffix) ->
128-
printExtension (Just vendor) moduleNameSuffix comment $
120+
printExtension (Just (extensionNameCategory n)) moduleNameSuffix comment $
129121
executeModifications api prof registry mods
130122

123+
-- We only consider non-empty supported extensions/modifications for the given API.
124+
supportedExtensions :: API -> Registry -> [(ExtensionName, [Modification])]
125+
supportedExtensions api registry =
126+
[ nameAndMods
127+
| ext <- extensions registry
128+
, api `supports` extensionSupported ext
129+
, nameAndMods@(_,(_:_)) <- [nameAndModifications api ext] ]
130+
where nameAndModifications :: API -> Extension -> (ExtensionName, [Modification])
131+
nameAndModifications api e =
132+
(extensionName e,
133+
[ conditionalModificationModification cm
134+
| cm <- extensionsRequireRemove e
135+
, api `matches` conditionalModificationAPI cm
136+
-- ARB_compatibility has an empty "require" element only
137+
, not . null . modificationInterfaceElements . conditionalModificationModification $ cm ])
138+
131139
fixRegistryPath :: String -> String
132140
fixRegistryPath path = case path of
133141
"3DFX/multisample" -> "3DFX/3dfx_multisample"
@@ -157,10 +165,10 @@ isProfileDependent :: Modification -> Bool
157165
isProfileDependent = DM.isJust . modificationProfile
158166

159167
startModule :: Maybe String -> String -> Maybe String -> [String] -> (String -> SI.Handle -> IO ()) -> IO ()
160-
startModule mbVendor moduleNameSuffix mbPragma comments action = do
168+
startModule mbCategory moduleNameSuffix mbPragma comments action = do
161169
let moduleNameParts =
162170
["Graphics", "Rendering", "OpenGL", "Raw"] ++
163-
maybe [] (\vendor -> [fixVendor vendor]) mbVendor ++
171+
maybe [] (\category -> [fixCategory category]) mbCategory ++
164172
[moduleNameSuffix]
165173
path = F.joinPath moduleNameParts `F.addExtension` "hs"
166174
moduleName = L.intercalate "." moduleNameParts
@@ -169,8 +177,8 @@ startModule mbVendor moduleNameSuffix mbPragma comments action = do
169177
printModuleHeader h mbPragma moduleName comments
170178
action moduleName h
171179

172-
fixVendor :: String -> String
173-
fixVendor v = case v of
180+
fixCategory :: String -> String
181+
fixCategory v = case v of
174182
"3DFX" -> "ThreeDFX"
175183
_ -> v
176184

@@ -214,15 +222,6 @@ fixExtensionWord w pos = case w of
214222
"ycrcba" -> "YCrCbA"
215223
_ -> capitalize w
216224

217-
nameAndModifications :: API -> Extension -> (ExtensionName, [Modification])
218-
nameAndModifications api e =
219-
(extensionName e,
220-
[ conditionalModificationModification cm
221-
| cm <- extensionsRequireRemove e
222-
, api `matches` conditionalModificationAPI cm
223-
-- ARB_compatibility has an empty "require" element only
224-
, not . null . modificationInterfaceElements . conditionalModificationModification $ cm ])
225-
226225
supports :: API -> Maybe [API] -> Bool
227226
_ `supports` Nothing = True
228227
a `supports` Just apis = a `elem` apis
@@ -235,8 +234,8 @@ separate f = L.intercalate ",\n" . map (" " ++) . map f
235234

236235
-- Note that we handle features just like extensions.
237236
printExtension :: Maybe String -> String -> [String] -> ([TypeName], [Enum'], [Command]) -> IO ()
238-
printExtension mbVendor moduleNameSuffix comment (ts, es, cs) =
239-
startModule mbVendor moduleNameSuffix Nothing comment $ \moduleName h -> do
237+
printExtension mbCategory moduleNameSuffix comment (ts, es, cs) =
238+
startModule mbCategory moduleNameSuffix Nothing comment $ \moduleName h -> do
240239
SI.hPutStrLn h $ "module "++ moduleName ++ " ("
241240
CM.unless (null ts) $ do
242241
SI.hPutStrLn h " -- * Types"
@@ -430,3 +429,35 @@ showComment name sigElem
430429

431430
inlineCode :: String -> String
432431
inlineCode s = "@" ++ s ++ "@"
432+
433+
-- TODO: Use Either instead of error below?
434+
toEnumType :: ToEnumType
435+
toEnumType eNamespace eGroup eType suffix = TypeName $
436+
case (eNamespace, eGroup, eType, unTypeSuffix `fmap` suffix) of
437+
-- glx.xml
438+
(Just "GLXStrings", _, _, _) -> "String"
439+
(Just ('G':'L':'X':_), _, _, _) -> "CInt"
440+
441+
-- egl.xml
442+
-- TODO: EGLenum for EGL_OPENGL_API, EGL_OPENGL_ES_API, EGL_OPENVG_API, EGL_OPENVG_IMAGE?
443+
(Just ('E':'G':'L':_), _, Nothing, Just "ull") -> "EGLTime"
444+
(Just ('E':'G':'L':_), _, _, _) -> "EGLint"
445+
446+
-- wgl.xml
447+
(Just "WGLLayerPlaneMask", _, _, _) -> "UINT"
448+
(Just "WGLColorBufferMask", _, _, _) -> "UINT"
449+
(Just "WGLContextFlagsMask", _, _, _) -> "INT"
450+
(Just "WGLContextProfileMask", _, _, _) -> "INT"
451+
(Just "WGLImageBufferMaskI3D" , _, _, _) -> "UINT"
452+
(Just "WGLDXInteropMaskNV", _, _, _) -> "GLenum"
453+
(Just ('W':'G':'L':_), _, _, _) -> "CInt"
454+
455+
-- gl.xml
456+
(Just "OcclusionQueryEventMaskAMD", _, _, _) -> "GLuint"
457+
(Just "GL", Just "PathRenderingTokenNV", _, _) -> "GLubyte"
458+
(Just "GL", _, Just "bitmask", _) -> "GLbitfield"
459+
(Just "GL", _, Nothing, Just "u") -> "GLuint"
460+
(Just "GL", _, Nothing, Just "ull") -> "GLuint64"
461+
(Just "GL", _, Nothing, Nothing) -> "GLenum"
462+
463+
(_, _, _, _) -> error "can't determine enum type"

‎RegistryProcessor/src/MangledRegistry.hs‎

Lines changed: 29 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,14 @@
1+
-- This module is a convenience layer upon the Registry module which knows
2+
-- nothing about GL/GLX/EGL/WGL-specific things.
13
module MangledRegistry (
4+
ToEnumType,
25
parseRegistry,
36
Registry(..),
47
Type(..),
58
Group(..),
69
Enum'(..),
710
R.TypeName(..),
11+
R.TypeSuffix(..),
812
Command(..), commandName,
913
SignatureElement(..),
1014
Modification(..),
@@ -33,8 +37,10 @@ import qualified Numeric as N
3337
import qualified DeclarationParser as D
3438
import qualified Registry as R
3539

36-
parseRegistry :: String -> Either String Registry
37-
parseRegistry = fmap toRegistry . R.parseRegistry
40+
type ToEnumType = Maybe String -> Maybe String -> Maybe String -> Maybe R.TypeSuffix -> R.TypeName
41+
42+
parseRegistry :: ToEnumType -> String -> Either String Registry
43+
parseRegistry toEnumType str = toRegistry toEnumType `fmap` R.parseRegistry str
3844

3945
data Registry = Registry {
4046
types :: M.Map R.TypeName Type,
@@ -45,8 +51,8 @@ data Registry = Registry {
4551
extensions :: [Extension]
4652
} deriving (Eq, Ord, Show)
4753

48-
toRegistry :: R.Registry -> Registry
49-
toRegistry r = Registry {
54+
toRegistry :: ToEnumType -> R.Registry -> Registry
55+
toRegistry toEnumType r = Registry {
5056
types = fromList'
5157
[ (typeNameOf t, toType t)
5258
| R.TypesElement te <- rs
@@ -59,7 +65,7 @@ toRegistry r = Registry {
5965
[ (enumName en, [en])
6066
| R.EnumsElement ee <- rs
6167
, Left e <- R.enumsEnumOrUnuseds ee
62-
, let en = toEnum' (R.enumsNamespace ee) (R.enumsGroup ee) (R.enumsType ee) e ],
68+
, let en = toEnum' (toEnumType (R.enumsNamespace ee) (R.enumsGroup ee) (R.enumsType ee)) e ],
6369
commands = fromList'
6470
[ (CommandName . R.protoName . R.commandProto $ c, toCommand c)
6571
| R.CommandsElement ce <- rs
@@ -113,11 +119,11 @@ data Enum' = Enum {
113119
enumName :: EnumName
114120
} deriving (Eq, Ord, Show)
115121

116-
toEnum' :: Maybe String -> Maybe String -> Maybe String -> R.Enum' -> Enum'
117-
toEnum' eNamespace eGroup eType e = Enum {
122+
toEnum' :: (Maybe R.TypeSuffix -> R.TypeName) -> R.Enum' -> Enum'
123+
toEnum' toTypeName e = Enum {
118124
enumValue = EnumValue (R.enumValue e),
119125
enumAPI = API `fmap` R.enumAPI e,
120-
enumType = toEnumType eNamespace eGroup eType (R.enumType e),
126+
enumType = toTypeName (R.enumType e),
121127
enumName = mangleEnumName (R.enumName e) }
122128

123129
mangleEnumName :: String -> EnumName
@@ -132,38 +138,6 @@ splitBy p xs = case break p xs of
132138
(ys, [] ) -> [ys]
133139
(ys, _:zs) -> ys : splitBy p zs
134140

135-
-- TODO: Use Either instead of error below?
136-
toEnumType :: Maybe String -> Maybe String -> Maybe String -> Maybe R.TypeSuffix -> R.TypeName
137-
toEnumType eNamespace eGroup eType suffix = R.TypeName $
138-
case (eNamespace, eGroup, eType, R.unTypeSuffix `fmap` suffix) of
139-
-- glx.xml
140-
(Just "GLXStrings", _, _, _) -> "String"
141-
(Just ('G':'L':'X':_), _, _, _) -> "CInt"
142-
143-
-- egl.xml
144-
-- TODO: EGLenum for EGL_OPENGL_API, EGL_OPENGL_ES_API, EGL_OPENVG_API, EGL_OPENVG_IMAGE?
145-
(Just ('E':'G':'L':_), _, Nothing, Just "ull") -> "EGLTime"
146-
(Just ('E':'G':'L':_), _, _, _) -> "EGLint"
147-
148-
-- wgl.xml
149-
(Just "WGLLayerPlaneMask", _, _, _) -> "UINT"
150-
(Just "WGLColorBufferMask", _, _, _) -> "UINT"
151-
(Just "WGLContextFlagsMask", _, _, _) -> "INT"
152-
(Just "WGLContextProfileMask", _, _, _) -> "INT"
153-
(Just "WGLImageBufferMaskI3D" , _, _, _) -> "UINT"
154-
(Just "WGLDXInteropMaskNV", _, _, _) -> "GLenum"
155-
(Just ('W':'G':'L':_), _, _, _) -> "CInt"
156-
157-
-- gl.xml
158-
(Just "OcclusionQueryEventMaskAMD", _, _, _) -> "GLuint"
159-
(Just "GL", Just "PathRenderingTokenNV", _, _) -> "GLubyte"
160-
(Just "GL", _, Just "bitmask", _) -> "GLbitfield"
161-
(Just "GL", _, Nothing, Just "u") -> "GLuint"
162-
(Just "GL", _, Nothing, Just "ull") -> "GLuint64"
163-
(Just "GL", _, Nothing, Nothing) -> "GLenum"
164-
165-
(_, _, _, _) -> error "can't determine enum type"
166-
167141
data Command = Command {
168142
resultType :: SignatureElement,
169143
paramTypes :: [SignatureElement],
@@ -256,7 +230,7 @@ data Extension = Extension {
256230

257231
toExtension :: R.Extension -> Extension
258232
toExtension e = Extension {
259-
extensionName = ExtensionName . R.unName . R.extensionName $ e,
233+
extensionName = toExtensionName $ R.extensionName e,
260234
extensionSupported = supp `fmap` R.extensionSupported e,
261235
extensionsRequireRemove = map toConditionalModification (R.extensionsRequireRemove e) }
262236
where supp = map API . splitBy (== '|') . R.unStringGroup
@@ -298,7 +272,20 @@ newtype EnumValue = EnumValue { unEnumValue :: String } deriving (Eq, Ord, Show)
298272

299273
newtype CommandName = CommandName { unCommandName :: String } deriving (Eq, Ord, Show)
300274

301-
newtype ExtensionName = ExtensionName { unExtensionName :: String } deriving (Eq, Ord, Show)
275+
-- See https://www.opengl.org/registry/doc/rules.html#spec_naming
276+
data ExtensionName = ExtensionName {
277+
extensionNameAPI :: String,
278+
extensionNameCategory :: String,
279+
extensionNameName :: String
280+
} deriving (Eq, Ord, Show)
281+
282+
toExtensionName :: R.Name -> ExtensionName
283+
toExtensionName name = ExtensionName {
284+
extensionNameAPI = a,
285+
extensionNameCategory = c,
286+
extensionNameName = n }
287+
where (a, _:rest) = break (== '_') (R.unName name)
288+
(c, _:n) = break (== '_') rest
302289

303290
newtype API = API { unAPI :: String } deriving (Eq, Ord, Show)
304291

0 commit comments

Comments
 (0)