Skip to content

Commit 6ed03fe

Browse files
svenpannesvenpanne
committed
Emit enums and command separately.
1 parent 29a6564 commit 6ed03fe

File tree

3 files changed

+185
-115
lines changed

3 files changed

+185
-115
lines changed

‎RegistryProcessor/generate-modules‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
#! /bin/sh
2+
set -e
3+
4+
OUTDIR="gen"
5+
MODDIR="$OUTDIR/Graphics/Rendering/OpenGL/Raw"
6+
REGISTRY="OpenGL-Registry/gl.xml"
7+
API="gl"
8+
9+
function runconverter() {
10+
echo "running" $@ 1>&2
11+
cabal run -v0 -- "$REGISTRY" "--api=$API" $@
12+
}
13+
14+
mkdir -p "$MODDIR"
15+
16+
runconverter --print-tokens > "$MODDIR/Tokens.hs"
17+
runconverter --print-functions > "$MODDIR/Functions.hs"
18+
19+
for i in 1.0 1.1 1.2 1.3 1.4 1.5 2.0 2.1; do
20+
runconverter --print-feature --version=$i --profile=version > "$MODDIR/Version"${i/\./}.hs
21+
done
22+
23+
for i in 3.0 3.1 3.2 3.3 4.0 4.1 4.2 4.3 4.4 4.5; do
24+
runconverter --print-feature --version=$i --profile=core > "$MODDIR/Core"${i/\./}.hs
25+
runconverter --print-feature --version=$i --profile=compatibility > "$MODDIR/Compatibility"${i/\./}.hs
26+
done

‎RegistryProcessor/src/Main.hs‎

Lines changed: 138 additions & 107 deletions
Original file line numberDiff line numberDiff line change
@@ -1,91 +1,156 @@
1-
module Main where
1+
module Main ( main ) where
22

3-
import Control.Monad
4-
import Data.Char
5-
import Data.List
6-
import Data.Maybe
3+
import qualified Control.Monad as CM
4+
import qualified Data.Char as C
5+
import qualified Data.List as L
76
import qualified Data.Map as M
7+
import qualified Data.Maybe as DM
88
import qualified Data.Set as S
9-
import System.Console.GetOpt
10-
import System.Environment
11-
import qualified Registry as R
9+
import qualified System.Console.GetOpt as G
10+
import qualified System.Environment as E
1211
import MangledRegistry
1312

1413
data Option
15-
= PrintXML
16-
| PrintRaw
17-
| PrintProcessed
18-
| PrintCommands
19-
| PrintCommandTypes
20-
| PrintFeatureCommands
14+
= PrintFeature
15+
| PrintTokens
16+
| PrintFunctions
2117
| UseApi API
2218
| UseVersion Version
2319
| UseProfile ProfileName
2420
deriving Eq
2521

26-
options :: [OptDescr Option]
22+
options :: [G.OptDescr Option]
2723
options =
28-
[ Option ['x'] ["print-xml"] (NoArg PrintXML) "print XML"
29-
, Option ['r'] ["print-raw"] (NoArg PrintRaw) "print raw registry"
30-
, Option ['p'] ["print-processed"] (NoArg PrintProcessed) "print processed registry"
31-
, Option ['c'] ["print-commands"] (NoArg PrintCommands) "print commands"
32-
, Option ['t'] ["print-command-types"] (NoArg PrintCommandTypes) "print command types"
33-
, Option ['C'] ["print-feature-commands"] (NoArg PrintFeatureCommands) "print feature commands"
34-
, Option ['a'] ["api"] (ReqArg (UseApi . API) "API") "extract features for API (default: gl)"
35-
, Option ['v'] ["version"] (ReqArg (UseVersion . read) "VERSION") "extract features for version (default: 1.0)"
36-
, Option ['P'] ["profile"] (ReqArg (UseProfile . ProfileName) "PROFILE") "extract features for profile (default: core)" ]
24+
[ G.Option ['F'] ["print-feature"] (G.NoArg PrintFeature) "print feature"
25+
, G.Option ['t'] ["print-tokens"] (G.NoArg PrintTokens) "print tokens"
26+
, G.Option ['f'] ["print-functions"] (G.NoArg PrintFunctions) "print functions"
27+
, G.Option ['a'] ["api"] (G.ReqArg (UseApi . API) "API") "extract features for API (default: gl)"
28+
, G.Option ['v'] ["version"] (G.ReqArg (UseVersion . read) "VERSION") "extract features for version (default: 4.5)"
29+
, G.Option ['p'] ["profile"] (G.ReqArg (UseProfile . ProfileName) "PROFILE") "extract features for profile (default: compatibility)" ]
3730

3831
getPaths :: IO ([Option], FilePath)
3932
getPaths = do
40-
args <- getArgs
41-
case getOpt Permute options args of
33+
args <- E.getArgs
34+
case G.getOpt G.Permute options args of
4235
(opts, [path], []) -> return (opts, path)
4336
(_, _, errs) -> do
44-
n <- getProgName
37+
n <- E.getProgName
4538
let header = "Usage: " ++ n ++ " [OPTION]... file"
46-
ioError (userError (concat errs ++ usageInfo header options))
39+
ioError (userError (concat errs ++ G.usageInfo header options))
4740

4841
main :: IO ()
4942
main = do
5043
(opts, path) <- getPaths
5144
let api = head ([ a | UseApi a <- opts ] ++ [ API "gl" ])
52-
version = head ([ v | UseVersion v <- opts ] ++ [ read "1.0" ])
53-
profile = head ([ p | UseProfile p <- opts ] ++ [ ProfileName "core" ])
54-
str <- readFile path
55-
when (PrintXML `elem` opts) $ do
56-
putStrLn "---------------------------------------- XML registry"
57-
either putStrLn (putStrLn . R.unparseRegistry) $ R.parseRegistry str
58-
when (PrintRaw `elem` opts) $ do
59-
putStrLn "---------------------------------------- raw registry"
60-
either putStrLn print $ R.parseRegistry str
61-
when (PrintProcessed `elem` opts) $ do
62-
putStrLn "---------------------------------------- processed registry"
63-
either putStrLn print $ parseRegistry str
64-
when (PrintCommands `elem` opts) $ do
65-
putStrLn "---------------------------------------- commands"
66-
either putStrLn (mapM_ print . M.elems . commands) $ parseRegistry str
67-
when (PrintCommandTypes `elem` opts) $ do
68-
either putStrLn (\r -> do putStr moduleHeader
69-
mapM_ (putStrLn . showCommand) . M.elems . commands $ r) $ parseRegistry str
70-
when (PrintFeatureCommands `elem` opts) $ do
71-
putStrLn $ "---------------------------------------- commands for feature " ++ unAPI api ++ " " ++ show version ++ " " ++ unProfileName profile
72-
either putStrLn (\r -> do let tec@(_ts,es,cs) = getTyEnCo api version profile r
73-
putStr "module Foo (\n "
74-
putStr (intercalate ",\n " (exports tec))
75-
putStrLn "\n) where"
76-
putStrLn moduleHeader
77-
mapM_ (putStrLn . unlines . convertEnum) es
78-
mapM_ (putStrLn . showCommand) cs
79-
) $ parseRegistry str
80-
81-
exports :: ([TypeName],[Enum'],[Command]) -> [String]
82-
exports (ts,es,cs) =
83-
["-- * Types"] ++
84-
map unTypeName ts ++
85-
["-- * Enums"] ++
86-
map (unEnumName . mangleEnumName . enumName) es ++
87-
["-- * Commands"] ++
88-
map (unCommandName . commandName) cs
45+
version = head ([ v | UseVersion v <- opts ] ++ [ read "4.5" ])
46+
profile = head ([ p | UseProfile p <- opts ] ++ [ ProfileName "compatibility" ])
47+
res <- fmap parseRegistry $ readFile path
48+
case res of
49+
Left msg -> putStrLn msg
50+
Right registry -> do
51+
CM.when (PrintFeature `elem` opts) $ do
52+
let modName = "Graphics.Rendering.OpenGL.Raw." ++
53+
capitalize (unProfileName profile) ++
54+
show (major version) ++ show (minor version)
55+
putStrLn "--------------------------------------------------------------------------------"
56+
putStrLn "-- |"
57+
putStrLn $ "-- Module : " ++ modName
58+
putStrLn "-- Copyright : (c) Sven Panne 2015"
59+
putStrLn "-- License : BSD3"
60+
putStrLn "--"
61+
putStrLn "-- Maintainer : Sven Panne <[email protected]>"
62+
putStrLn "-- Stability : stable"
63+
putStrLn "-- Portability : portable"
64+
putStrLn "--"
65+
putStrLn "--------------------------------------------------------------------------------"
66+
putStrLn ""
67+
let (ts,es,cs) = getTyEnCo api version profile registry
68+
putStrLn $ "module "++ modName ++ " ("
69+
CM.unless (null ts) $ do
70+
putStrLn " -- * Types"
71+
putStr $ separate unTypeName ts
72+
putStrLn $ if null es && null cs then "" else ","
73+
CM.unless (null es) $ do
74+
putStrLn " -- * Enums"
75+
putStr $ separate (unEnumName . enumName) es
76+
putStrLn $ if null cs then "" else ","
77+
CM.unless (null cs) $ do
78+
putStrLn " -- * Functions"
79+
putStr $ separate (unCommandName . commandName) cs
80+
putStrLn ""
81+
putStrLn ") where"
82+
putStrLn ""
83+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Types"
84+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Tokens"
85+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Functions"
86+
CM.when (PrintTokens `elem` opts) $ do
87+
putStrLn "--------------------------------------------------------------------------------"
88+
putStrLn "-- |"
89+
putStrLn "-- Module : Graphics.Rendering.OpenGL.Raw.Tokens"
90+
putStrLn "-- Copyright : (c) Sven Panne 2015"
91+
putStrLn "-- License : BSD3"
92+
putStrLn "--"
93+
putStrLn "-- Maintainer : Sven Panne <[email protected]>"
94+
putStrLn "-- Stability : stable"
95+
putStrLn "-- Portability : portable"
96+
putStrLn "--"
97+
putStrLn "-- All enumeration tokens from the OpenGL registry, see"
98+
putStrLn "-- <http://www.opengl.org/registry/>."
99+
putStrLn "--"
100+
putStrLn "--------------------------------------------------------------------------------"
101+
putStrLn ""
102+
putStrLn "module Graphics.Rendering.OpenGL.Raw.Tokens where"
103+
putStrLn ""
104+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Types"
105+
putStrLn ""
106+
mapM_ (putStrLn . unlines . convertEnum)
107+
[ e
108+
| es <- M.elems (enums registry)
109+
, e <- es
110+
, api `matches` enumAPI e ]
111+
CM.when (PrintFunctions `elem` opts) $ do
112+
putStrLn "{-# LANGUAGE CPP #-}"
113+
putStrLn "--------------------------------------------------------------------------------"
114+
putStrLn "-- |"
115+
putStrLn "-- Module : Graphics.Rendering.OpenGL.Raw.Functions"
116+
putStrLn "-- Copyright : (c) Sven Panne 2015"
117+
putStrLn "-- License : BSD3"
118+
putStrLn "--"
119+
putStrLn "-- Maintainer : Sven Panne <[email protected]>"
120+
putStrLn "-- Stability : stable"
121+
putStrLn "-- Portability : portable"
122+
putStrLn "--"
123+
putStrLn "-- All raw functions from the OpenGL registry, see"
124+
putStrLn "-- <http://www.opengl.org/registry/>."
125+
putStrLn "--"
126+
putStrLn "--------------------------------------------------------------------------------"
127+
putStrLn ""
128+
putStrLn "module Graphics.Rendering.OpenGL.Raw.Functions ("
129+
putStrLn . separate unCommandName . M.keys . commands $registry
130+
putStrLn ") where"
131+
putStrLn ""
132+
putStrLn "import Foreign.C.Types"
133+
putStrLn "import Foreign.Marshal.Error ( throwIf )"
134+
putStrLn "import Foreign.Ptr ( Ptr, FunPtr, nullFunPtr )"
135+
putStrLn "import System.IO.Unsafe ( unsafePerformIO )"
136+
putStrLn ""
137+
putStrLn "import Graphics.Rendering.OpenGL.Raw.GetProcAddress ( getProcAddress )"
138+
putStrLn "import Graphics.Rendering.OpenGL.Raw.Types"
139+
putStrLn ""
140+
putStrLn "getCommand :: String -> IO (FunPtr a)"
141+
putStrLn "getCommand cmd ="
142+
putStrLn " throwIfNullFunPtr (\"unknown OpenGL command \" ++ cmd) $ getProcAddress cmd"
143+
putStrLn ""
144+
putStrLn "throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)"
145+
putStrLn "throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
146+
putStrLn ""
147+
mapM_ (putStrLn . showCommand) (M.elems (commands registry))
148+
149+
capitalize :: String -> String
150+
capitalize str = C.toUpper (head str) : tail str
151+
152+
separate :: (a -> String) -> [a] -> String
153+
separate f = L.intercalate ",\n" . map (" " ++) . map f
89154

90155
getTyEnCo :: API -> Version -> ProfileName -> Registry -> ([TypeName],[Enum'],[Command])
91156
getTyEnCo api version profile registry = (ts', es, cs)
@@ -95,8 +160,8 @@ getTyEnCo api version profile registry = (ts', es, cs)
95160
, api `matches` enumAPI e ]
96161
cs = [ lookup' n (commands registry) | CommandElement n <- lst ]
97162
-- Features don't explicitly list the types referenced by commands.
98-
ts' = S.toList (S.unions (S.fromList ts : map referencedTypes cs))
99-
lst = S.toList (interfaceElementsFor api version profile registry)
163+
ts' = S.toList . S.unions $ S.fromList ts : map referencedTypes cs
164+
lst = S.toList $ interfaceElementsFor api version profile registry
100165

101166
-- Here is the heart of the feature construction logic: Chronologically replay
102167
-- the whole version history for the given API/version/profile triple.
@@ -105,7 +170,7 @@ interfaceElementsFor api version profile registry =
105170
foldl (flip ($)) S.empty modificationsFor
106171
where modificationsFor =
107172
[ op (modificationKind m) ie
108-
| key <- sort keys
173+
| key <- L.sort keys
109174
, m <- lookup' key (features registry)
110175
, profile `matches` modificationProfile m
111176
, ie <- modificationInterfaceElements m ]
@@ -127,39 +192,7 @@ convertEnum :: Enum' -> [String]
127192
convertEnum e =
128193
[ n ++ " :: " ++ unTypeName (enumType e)
129194
, n ++ " = " ++ unEnumValue (enumValue e) ]
130-
where n = unEnumName . mangleEnumName . enumName $ e
131-
132-
-- TODO: Move to MangledRegistry?
133-
mangleEnumName :: EnumName -> EnumName
134-
mangleEnumName =
135-
EnumName . intercalate [splitChar] . headToLower . splitBy (== splitChar) . unEnumName
136-
where splitChar = '_'
137-
headToLower xs = map toLower (head xs) : tail xs
138-
139-
splitBy :: (a -> Bool) -> [a] -> [[a]]
140-
splitBy _ [] = []
141-
splitBy p xs = case break p xs of
142-
(ys, [] ) -> [ys]
143-
(ys, _:zs) -> ys : splitBy p zs
144-
145-
-- TODO: Everything below is currently a cruel hack, clean this up!
146-
147-
moduleHeader :: String
148-
moduleHeader = unlines [
149-
"",
150-
"import Foreign.C.Types",
151-
"import Foreign.Ptr",
152-
"import System.IO.Unsafe",
153-
"",
154-
"import Graphics.Rendering.OpenGL.Raw.GetProcAddress",
155-
"import Graphics.Rendering.OpenGL.Raw.Types",
156-
"",
157-
"getExtensionEntry :: String -> String -> IO (FunPtr a)",
158-
"getExtensionEntry _ = getProcAddress",
159-
"",
160-
"extensionNameString :: String",
161-
"extensionNameString = \"OpenGL 4.5\"",
162-
""]
195+
where n = unEnumName . enumName $ e
163196

164197
showCommand :: Command -> String
165198
showCommand c =
@@ -169,25 +202,23 @@ showCommand c =
169202
showString (" :: " ++ signature True) .
170203
showString (name ++ " = " ++ dyn_name ++ " " ++ ptr_name ++ "\n\n") .
171204

172-
showString ("foreign import" ++ callconv ++ " unsafe \"dynamic\" " ++ dyn_name ++ "\n" ++
205+
showString ("foreign import CALLCONV unsafe \"dynamic\" " ++ dyn_name ++ "\n" ++
173206
" :: FunPtr (" ++ compactSignature ++ ")\n" ++
174207
" -> " ++ compactSignature ++ "\n\n") .
175208

176209
showString ("{-# NOINLINE " ++ ptr_name ++ " #-}\n") .
177210
showString (ptr_name ++ " :: FunPtr (" ++ compactSignature ++ ")\n") .
178-
showString (ptr_name ++ " = unsafePerformIO $\n" ++
179-
" getExtensionEntry extensionNameString " ++ str_name ++ "\n") .
211+
showString (ptr_name ++ " = unsafePerformIO $ getCommand " ++ str_name ++ "\n") .
180212

181213
id $ ""
182214

183215
where name = signatureElementName (resultType c)
184216
dyn_name = "dyn_" ++ name
185217
ptr_name = "ptr_" ++ name
186218
str_name = show name
187-
callconv = " ccall"
188219
compactSignature = signature False
189220
signature withComment =
190-
intercalate ((if withComment then " " else "") ++ " -> ")
221+
L.intercalate ((if withComment then " " else "") ++ " -> ")
191222
([showSignatureElement withComment False t | t <- paramTypes c] ++
192223
[showSignatureElement withComment True (resultType c)])
193224

@@ -211,7 +242,7 @@ showComment name sigElem
211242
info | isInteresting = elms ++ " of type " ++ inlineCode (show (base sigElem))
212243
| otherwise = ""
213244

214-
isInteresting = isJust (arrayLength sigElem) || isJust (belongsToGroup sigElem)
245+
isInteresting = DM.isJust (arrayLength sigElem) || DM.isJust (belongsToGroup sigElem)
215246

216247
elms | numPointer sigElem > 0 = " pointing to" ++ len ++ " elements"
217248
| otherwise = ""

0 commit comments

Comments
 (0)