Skip to content

Commit eea866e

Browse files
svenpannesvenpanne
committed
First steps towards generating extensions.
1 parent a0ee638 commit eea866e

File tree

2 files changed

+181
-59
lines changed

2 files changed

+181
-59
lines changed

‎RegistryProcessor/src/Main.hs‎

Lines changed: 155 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ data Option
1515
= PrintFeature
1616
| PrintTokens
1717
| PrintFunctions
18+
| PrintExtensions
1819
| UseApi API
1920
| UseVersion Version
2021
| UseProfile ProfileName
@@ -25,6 +26,7 @@ options =
2526
[ G.Option ['F'] ["print-feature"] (G.NoArg PrintFeature) "print feature"
2627
, G.Option ['t'] ["print-tokens"] (G.NoArg PrintTokens) "print tokens"
2728
, G.Option ['f'] ["print-functions"] (G.NoArg PrintFunctions) "print functions"
29+
, G.Option ['x'] ["print-extensions"] (G.NoArg PrintExtensions) "print extensions"
2830
, G.Option ['a'] ["api"] (G.ReqArg (UseApi . API) "API") "extract features for API (default: gl)"
2931
, G.Option ['v'] ["version"] (G.ReqArg (UseVersion . read) "VERSION") "extract features for version (default: 4.5)"
3032
, G.Option ['p'] ["profile"] (G.ReqArg (UseProfile . ProfileName) "PROFILE") "extract features for profile (default: compatibility)" ]
@@ -53,37 +55,8 @@ main = do
5355
let modName = "Graphics.Rendering.OpenGL.Raw." ++
5456
capitalize (unProfileName profile) ++
5557
show (major version) ++ show (minor version)
56-
putStrLn "--------------------------------------------------------------------------------"
57-
putStrLn "-- |"
58-
putStrLn $ "-- Module : " ++ modName
59-
putStrLn "-- Copyright : (c) Sven Panne 2015"
60-
putStrLn "-- License : BSD3"
61-
putStrLn "--"
62-
putStrLn "-- Maintainer : Sven Panne <[email protected]>"
63-
putStrLn "-- Stability : stable"
64-
putStrLn "-- Portability : portable"
65-
putStrLn "--"
66-
putStrLn "--------------------------------------------------------------------------------"
67-
putStrLn ""
68-
let (ts,es,cs) = fixedGetTyEnCo api version profile registry
69-
putStrLn $ "module "++ modName ++ " ("
70-
CM.unless (null ts) $ do
71-
putStrLn " -- * Types"
72-
putStr $ separate unTypeName ts
73-
putStrLn $ if null es && null cs then "" else ","
74-
CM.unless (null es) $ do
75-
putStrLn " -- * Enums"
76-
putStr $ separate (unEnumName . enumName) es
77-
putStrLn $ if null cs then "" else ","
78-
CM.unless (null cs) $ do
79-
putStrLn " -- * Functions"
80-
putStr $ separate (unCommandName . commandName) cs
81-
putStrLn ""
82-
putStrLn ") where"
83-
putStrLn ""
84-
putStrLn "import Graphics.Rendering.OpenGL.Raw.Types"
85-
putStrLn "import Graphics.Rendering.OpenGL.Raw.Tokens"
86-
putStrLn "import Graphics.Rendering.OpenGL.Raw.Functions"
58+
(ts,es,cs) = fixedReplay api version profile registry
59+
printMod modName ts es cs
8760
CM.when (PrintTokens `elem` opts) $ do
8861
putStrLn "--------------------------------------------------------------------------------"
8962
putStrLn "-- |"
@@ -146,48 +119,175 @@ main = do
146119
putStrLn "throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
147120
putStrLn ""
148121
mapM_ (putStrLn . showCommand api) (M.elems (commands registry))
122+
CM.when (PrintExtensions `elem` opts) $ do
123+
-- only consider non-empty supported extensions/modifications for the given API
124+
let supportedExtensions =
125+
[ nameAndMods
126+
| ext <- extensions registry
127+
, api `supports` extensionSupported ext
128+
, nameAndMods@(_,(_:_)) <- [nameAndModifications api ext] ]
129+
130+
let (profileDependent, profileIndependent) =
131+
L.partition (any (DM.isJust . modificationProfile) . snd) supportedExtensions
132+
putStrLn "======================================== profile-dependent extensions"
133+
CM.forM_ ["core", "compatibility"] $ \prof -> do
134+
CM.forM_ profileDependent $ \(n,mods) -> do
135+
let (_vendor, modName) = mangleExtensionName (extendExtensionName n (ProfileName prof))
136+
(ts,es,cs) = executeModifications api (ProfileName prof) registry mods
137+
printMod modName ts es cs
138+
139+
putStrLn "======================================== profile-independent extensions"
140+
CM.forM_ profileIndependent $ \(n,mods) -> do
141+
let (_vendor, modName) = mangleExtensionName n
142+
(ts,es,cs) = executeModifications api profile registry mods
143+
printMod modName ts es cs
144+
145+
extendExtensionName :: ExtensionName -> ProfileName -> ExtensionName
146+
extendExtensionName n profile =
147+
ExtensionName . (++ ("_" ++ unProfileName profile)). unExtensionName $ n
148+
149+
mangleExtensionName :: ExtensionName -> (String,String)
150+
mangleExtensionName n = (vendor, modName)
151+
where ("GL":vendor:rest) = splitBy (== '_') (unExtensionName n)
152+
modName = "Graphics.Rendering.OpenGL.Raw." ++ fixVendor vendor ++ "." ++ concatMap fixExtensionWord rest
153+
154+
fixVendor :: String -> String
155+
fixVendor v = case v of
156+
"3DFX" -> "ThreeDFX"
157+
_ -> v
158+
159+
fixExtensionWord :: String -> String
160+
fixExtensionWord w = case w of
161+
"422" -> "FourTwoTwo" -- !!!!!!!!!!!!!!!!!!!
162+
"64bit" -> "64Bit"
163+
"ES2" -> "ES2"
164+
"ES3" -> "ES3"
165+
"FXT1" -> "FXT1"
166+
"a2ui" -> "A2UI"
167+
"abgr" -> "ABGR"
168+
"astc" -> "ASTC"
169+
"bgra" -> "BGRA"
170+
"bptc" -> "BPTC"
171+
"cl" -> "CL"
172+
"cmyka" -> "CMYKA"
173+
"dxt1" -> "DXT1"
174+
"es" -> "ES"
175+
"fp64" -> "FP64"
176+
"gpu" -> "GPU"
177+
"hdr" -> "HDR"
178+
"latc" -> "LATC"
179+
"ldr" -> "LDR"
180+
"lod" -> "LOD"
181+
"pn" -> "PN"
182+
"rg" -> "RG"
183+
"rgb" -> "RGB"
184+
"rgb10" -> "RGB10"
185+
"rgtc" -> "RGTC"
186+
"s3tc" -> "S3TC"
187+
"sRGB" -> "SRGB"
188+
"snorm" -> "SNorm"
189+
"tbuffer" -> "TBuffer"
190+
"texture3D" -> "Texture3D"
191+
"texture4D" -> "Texture4D"
192+
"vdpau" -> "VDPAU"
193+
"ycbcr" -> "YCbCr"
194+
"ycrcb" -> "YCrCb"
195+
"ycrcba" -> "YCrCbA"
196+
_ -> capitalize w
197+
198+
nameAndModifications :: API -> Extension -> (ExtensionName, [Modification])
199+
nameAndModifications api e =
200+
(extensionName e,
201+
[ conditionalModificationModification cm
202+
| cm <- extensionsRequireRemove e
203+
, api `matches` conditionalModificationAPI cm ])
204+
205+
supports :: API -> Maybe [API] -> Bool
206+
_ `supports` Nothing = True
207+
a `supports` Just apis = a `elem` apis
149208

150209
capitalize :: String -> String
151-
capitalize str = C.toUpper (head str) : tail str
210+
capitalize str = C.toUpper (head str) : map C.toLower (tail str)
152211

153212
separate :: (a -> String) -> [a] -> String
154213
separate f = L.intercalate ",\n" . map (" " ++) . map f
155214

215+
printMod :: String -> [TypeName] -> [Enum'] -> [Command] -> IO ()
216+
printMod modName ts es cs= do
217+
putStrLn "--------------------------------------------------------------------------------"
218+
putStrLn "-- |"
219+
putStrLn $ "-- Module : " ++ modName
220+
putStrLn "-- Copyright : (c) Sven Panne 2015"
221+
putStrLn "-- License : BSD3"
222+
putStrLn "--"
223+
putStrLn "-- Maintainer : Sven Panne <[email protected]>"
224+
putStrLn "-- Stability : stable"
225+
putStrLn "-- Portability : portable"
226+
putStrLn "--"
227+
putStrLn "--------------------------------------------------------------------------------"
228+
putStrLn ""
229+
putStrLn $ "module "++ modName ++ " ("
230+
CM.unless (null ts) $ do
231+
putStrLn " -- * Types"
232+
putStr $ separate unTypeName ts
233+
putStrLn $ if null es && null cs then "" else ","
234+
CM.unless (null es) $ do
235+
putStrLn " -- * Enums"
236+
putStr $ separate (unEnumName . enumName) es
237+
putStrLn $ if null cs then "" else ","
238+
CM.unless (null cs) $ do
239+
putStrLn " -- * Functions"
240+
putStr $ separate (unCommandName . commandName) cs
241+
putStrLn ""
242+
putStrLn ") where"
243+
putStrLn ""
244+
CM.unless (null ts) $
245+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Types"
246+
CM.unless (null es) $
247+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Tokens"
248+
CM.unless (null cs) $
249+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Functions"
250+
156251
-- Annoyingly enough, the OpenGL registry doesn't contain any enums for
157-
-- OpenGL 1.0, so let's just use the OpenGL 1.1 ones.
158-
fixedGetTyEnCo :: API -> Version -> ProfileName -> Registry -> ([TypeName],[Enum'],[Command])
159-
fixedGetTyEnCo api version profile registry
160-
| api == API "gl" && version == read "1.0" = (ts, es11, cs)
161-
| otherwise = tec
162-
where tec@(ts, _, cs) = getTyEnCo api version profile registry
163-
(_, es11, _) = getTyEnCo api (read "1.1") profile registry
164-
165-
getTyEnCo :: API -> Version -> ProfileName -> Registry -> ([TypeName],[Enum'],[Command])
166-
getTyEnCo api version profile registry = (ts', es, cs)
252+
-- OpenGL 1.0, so let's just use the OpenGL 1.1 ones. Furthermore, features
253+
-- don't explicitly list the types referenced by commands, so we add them.
254+
fixedReplay :: API -> Version -> ProfileName -> Registry -> ([TypeName],[Enum'],[Command])
255+
fixedReplay api version profile registry
256+
| api == API "gl" && version == read "1.0" = (ts', es11, cs)
257+
| otherwise = (ts', es, cs)
258+
where (ts, es, cs) = replay api version profile registry
259+
(_, es11, _) = replay api (read "1.1") profile registry
260+
ts' = S.toList . S.unions $ S.fromList ts : map referencedTypes cs
261+
262+
-- Here is the heart of the feature construction logic: Chronologically replay
263+
-- the whole version history for the given API/version/profile triple.
264+
replay :: API -> Version -> ProfileName -> Registry -> ([TypeName],[Enum'],[Command])
265+
replay api version profile registry =
266+
executeModifications api profile registry modifications
267+
where modifications = concatMap modificationsFor history
268+
modificationsFor = flip lookup' (features registry)
269+
history = L.sort [ key
270+
| key@(a,v) <- M.keys (features registry)
271+
, a == api
272+
, v <= version ]
273+
274+
executeModifications :: API -> ProfileName -> Registry -> [Modification] -> ([TypeName], [Enum'], [Command])
275+
executeModifications api profile registry modifications = (ts, es, cs)
167276
where ts = [ n | TypeElement n <- lst ]
168277
es = [ e | EnumElement n <- lst
169278
, e <- lookup' n (enums registry)
170279
, api `matches` enumAPI e ]
171280
cs = [ lookup' n (commands registry) | CommandElement n <- lst ]
172-
-- Features don't explicitly list the types referenced by commands.
173-
ts' = S.toList . S.unions $ S.fromList ts : map referencedTypes cs
174-
lst = S.toList $ interfaceElementsFor api version profile registry
281+
lst = S.toList $ interfaceElementsFor profile modifications
175282

176-
-- Here is the heart of the feature construction logic: Chronologically replay
177-
-- the whole version history for the given API/version/profile triple.
178-
interfaceElementsFor :: API -> Version -> ProfileName -> Registry -> S.Set InterfaceElement
179-
interfaceElementsFor api version profile registry =
283+
interfaceElementsFor :: ProfileName -> [Modification] -> S.Set InterfaceElement
284+
interfaceElementsFor profile modifications =
180285
foldl (flip ($)) S.empty modificationsFor
181286
where modificationsFor =
182287
[ op (modificationKind m) ie
183-
| key <- L.sort keys
184-
, m <- lookup' key (features registry)
288+
| m <- modifications
185289
, profile `matches` modificationProfile m
186290
, ie <- modificationInterfaceElements m ]
187-
keys = [ key
188-
| key@(a,v) <- M.keys (features registry)
189-
, a == api
190-
, v <= version ]
191291
op Require = S.insert
192292
op Remove = S.delete
193293

‎RegistryProcessor/src/MangledRegistry.hs‎

Lines changed: 26 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,13 +11,16 @@ module MangledRegistry (
1111
R.ModificationKind(..),
1212
R.ProfileName(..),
1313
Extension(..),
14+
ConditionalModification(..),
1415
InterfaceElement(..),
1516
GroupName(..),
1617
EnumName(..),
1718
EnumValue(..),
1819
CommandName(..),
20+
ExtensionName(..),
1921
API(..),
20-
Version(..)
22+
Version(..),
23+
splitBy
2124
) where
2225

2326
import qualified Data.Char as C
@@ -245,11 +248,28 @@ toModification m = Modification {
245248
modificationProfile = R.modificationProfileName m,
246249
modificationInterfaceElements = map toInterfaceElement (R.modificationInterfaceElements m) }
247250

248-
data Extension = Extension
249-
deriving (Eq, Ord, Show)
251+
data Extension = Extension {
252+
extensionName :: ExtensionName,
253+
extensionSupported :: Maybe [API],
254+
extensionsRequireRemove :: [ConditionalModification]
255+
} deriving (Eq, Ord, Show)
250256

251257
toExtension :: R.Extension -> Extension
252-
toExtension _ = Extension
258+
toExtension e = Extension {
259+
extensionName = ExtensionName . R.unName . R.extensionName $ e,
260+
extensionSupported = supp `fmap` R.extensionSupported e,
261+
extensionsRequireRemove = map toConditionalModification (R.extensionsRequireRemove e) }
262+
where supp = map API . splitBy (== '|') . R.unStringGroup
263+
264+
data ConditionalModification = ConditionalModification {
265+
conditionalModificationAPI :: Maybe API,
266+
conditionalModificationModification :: Modification
267+
} deriving (Eq, Ord, Show)
268+
269+
toConditionalModification :: R.ConditionalModification -> ConditionalModification
270+
toConditionalModification c = ConditionalModification {
271+
conditionalModificationAPI = API `fmap` R.conditionalModificationAPI c,
272+
conditionalModificationModification = toModification (R.conditionalModificationModification c) }
253273

254274
data InterfaceElement
255275
= TypeElement R.TypeName
@@ -278,6 +298,8 @@ newtype EnumValue = EnumValue { unEnumValue :: String } deriving (Eq, Ord, Show)
278298

279299
newtype CommandName = CommandName { unCommandName :: String } deriving (Eq, Ord, Show)
280300

301+
newtype ExtensionName = ExtensionName { unExtensionName :: String } deriving (Eq, Ord, Show)
302+
281303
newtype API = API { unAPI :: String } deriving (Eq, Ord, Show)
282304

283305
data Version = Version {

0 commit comments

Comments
 (0)