OpenGLRaw-3.2.3.0: RegistryProcessor/src/Main.hs
module Main ( main ) where
import qualified Control.Monad as CM
import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Maybe as DM
import qualified Data.Set as S
import qualified Text.PrettyPrint.HughesPJClass as P
import qualified System.Directory as D
import qualified System.Environment as E
import qualified System.FilePath as F
import qualified System.IO as SI
import MangledRegistry
import ManPages
main :: IO ()
main = do
[a, registryPath] <- E.getArgs
let api = API a
res <- parseRegistry toEnumType `fmap` readFile registryPath
case res of
Left msg -> SI.hPutStrLn SI.stderr msg
Right registry -> do
printTokens api registry
printGroups api registry
let sigMap = signatureMap registry
printForeign sigMap
printFunctions api registry sigMap
let extModules = extensionModules api registry
CM.forM_ extModules printExtensionModule
printReExports extModules
printExtensionSupport extModules
CM.forM_ (openGLVersions api) $ \v ->
CM.forM_ (supportedProfiles api v) $ \p ->
printFeature api v p registry
printTopLevel api extModules
openGLVersions :: API -> [Version]
openGLVersions api = map read $ case unAPI api of
"gl" -> [ "1.0", "1.1", "1.2", "1.3", "1.4", "1.5",
"2.0", "2.1",
"3.0", "3.1", "3.2", "3.3",
"4.0", "4.1", "4.2", "4.3", "4.4", "4.5" ]
"gles1" -> [ "1.0" ]
"gles2" -> [ "2.0", "3.0", "3.1", "3.2" ]
a -> error $ "unknown API " ++ a
latestVersion :: API -> Version
latestVersion = last . openGLVersions
supportedProfiles :: API -> Version -> [Maybe ProfileName]
supportedProfiles api v = case unAPI api of
"gl" | major v < 3 -> [ Nothing ]
| otherwise -> map (Just . ProfileName) [ "core", "compatibility" ]
"gles1" -> map (Just . ProfileName) [ "lite", "common" ]
"gles2" -> [ Nothing ]
a -> error $ "unknown API " ++ a
latestProfiles :: API -> [Maybe ProfileName]
latestProfiles api = supportedProfiles api (latestVersion api)
profileToReExport :: API -> Maybe ProfileName
profileToReExport = last . latestProfiles
printFeature :: API -> Version -> Maybe ProfileName -> Registry -> IO ()
printFeature api version mbProfile registry =
printExtension [featureName version mbProfile] Nothing $
fixedReplay api version mbProfile registry
featureName :: Version -> Maybe ProfileName -> String
featureName version mbProfile =
maybe "Version" (capitalize . unProfileName) mbProfile ++
show (major version) ++ show (minor version)
printTokens :: API -> Registry -> IO ()
printTokens api registry = do
let cmnt =
[Comment "All enumeration tokens from the",
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
startModule ["Tokens"] (Just "{-# LANGUAGE CPP, PatternSynonyms, ScopedTypeVariables #-}\n#if __GLASGOW_HASKELL__ >= 800\n{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}\n#endif") cmnt $ \moduleName h -> do
hRender h $ Module moduleName P.empty
hRender h $ Import (moduleNameFor ["Types"]) P.empty
SI.hPutStrLn h ""
mapM_ (SI.hPutStrLn h . unlines . convertEnum)
[ e
| es <- M.elems (enums registry)
, e <- es
, api `matches` enumAPI e ]
printGroups :: API -> Registry -> IO ()
printGroups api registry = do
let cmnt =
[Comment "All enumeration groups from the",
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
startModule ["Groups"] Nothing cmnt $ \moduleName h -> do
hRender h $ Module moduleName (P.text "(\n -- $EnumerantGroups\n)")
hRender h $ Comment "$EnumerantGroups"
hRender h $ Comment "Note that the actual set of valid values depend on the OpenGL version, the"
hRender h $ Comment "chosen profile and the supported extensions. Therefore, the groups mentioned"
hRender h $ Comment "here should only be considered a rough guideline, for details see the OpenGL"
hRender h $ Comment "specification."
CM.forM_ (M.assocs (groups registry)) $ \(gn, g) -> do
let ugn = unGroupName gn
es = getGroupEnums api registry g
hRender h $ Comment ""
hRender h $ Comment ("=== #" ++ ugn ++ "# " ++ ugn)
hRender h $ Comment (groupHeader es)
hRender h $ Comment ""
-- TODO: Improve the alias computation below. It takes quadratic time and
-- is very naive about what is the canonical name and what is an alias.
CM.forM_ es $ \e -> do
let same = L.sort [ f | f <- es, enumValue e == enumValue f ]
CM.when (e == head same) $ do
hRender h $ Comment ("* " ++ linkToToken e ++
(case tail same of
[] -> ""
aliases -> " (" ++ al ++ ": " ++ L.intercalate ", " (map linkToToken aliases) ++ ")"
where al | length aliases == 1 = "alias"
| otherwise = "aliases"))
linkToToken :: Enum' -> String
linkToToken e = "'" ++ (case moduleNameFor ["Tokens"] of ModuleName mn -> mn) ++ "." ++ (unEnumName . enumName) e ++ "'"
-- There are several enums which are mentioned in groups, but commented out in
-- enums (12 GL_*_ICC_SGIX enumerants). These are implicitly filtered out below.
getGroupEnums :: API -> Registry -> Group -> [Enum']
getGroupEnums api registry g =
[ e | name <- groupEnums g
, Just es <- [ M.lookup name (enums registry) ]
, e <- es
, api `matches` enumAPI e ]
groupHeader :: [Enum'] -> String
groupHeader es = case sortUnique (map enumType es) of
-- There are 2 empty groups: DataType and FfdMaskSGIX.
[] -> "There are no values defined for this enumeration group."
[t] | isMask t -> "A bitwise combination of several of the following values:"
| otherwise -> "One of the following values:"
tys -> error $ "Contradicting enumerant types " ++ show tys
-- Calulate a map from compact signature to short names.
signatureMap :: Registry -> M.Map String String
signatureMap registry = fst $ M.foldl' step (M.empty, 0::Integer) (commands registry)
where step (m,n) command = memberAndInsert (n+1) n (sig command) (dyn n) m
sig = flip (showSignatureFromCommand registry) False
dyn n = "dyn" ++ show n
memberAndInsert notFound found key value theMap =
(newMap, maybe notFound (const found) maybeValue)
where (maybeValue, newMap) = M.insertLookupWithKey (\_ _ s -> s) key value theMap
printForeign :: M.Map String String -> IO ()
printForeign sigMap = do
let cmnt = [Comment "All foreign imports."]
startModule ["Foreign"] (Just "{-# LANGUAGE CPP #-}\n{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
hRender h $ Module moduleName P.empty
hRender h $ Import (ModuleName "Foreign.C.Types") P.empty
hRender h $ Import (ModuleName "Foreign.Marshal.Error") (P.text "( throwIf )")
hRender h $ Import (ModuleName "Foreign.Ptr") P.empty
hRender h $ Import (moduleNameFor ["GetProcAddress"]) (P.text "( getProcAddress )")
hRender h $ Import (moduleNameFor ["Types"]) P.empty
hRender h $ Import (ModuleName "Numeric.Fixed") P.empty
hRender h $ Import (ModuleName "Numeric.Half") P.empty
SI.hPutStrLn h ""
SI.hPutStrLn h "getCommand :: String -> IO (FunPtr a)"
SI.hPutStrLn h "getCommand cmd ="
SI.hPutStrLn h " throwIfNullFunPtr (\"unknown OpenGL command \" ++ cmd) $ getProcAddress cmd"
SI.hPutStrLn h " where throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)"
SI.hPutStrLn h " throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
SI.hPutStrLn h ""
mapM_ (SI.hPutStrLn h . uncurry makeImportDynamic) (M.assocs sigMap)
chunksOf :: Int -> [a] -> [[a]]
chunksOf n = takeWhile (not . null) . L.unfoldr (Just . splitAt n)
justifyRight :: Int -> a -> [a] -> [a]
justifyRight n c xs = reverse . take (max n (length xs)) . (++ repeat c) . reverse $ xs
printFunctions :: API -> Registry -> M.Map String String -> IO ()
printFunctions api registry sigMap = do
let cmnt =
[Comment "All raw functions from the",
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
cmds = chunksOf 100 . M.toAscList . commands $ registry
mnames = [ [ "Functions", "F" ++ justifyRight 2 '0' (show i) ] |
i <- [ 1 .. length cmds ] ]
startModule ["Functions"] Nothing cmnt $ \moduleName h -> do
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\x -> "module " ++ (case moduleNameFor x of ModuleName mn -> mn)) mnames ++ "\n)"))
CM.forM_ mnames $ \mname ->
hRender h $ Import (moduleNameFor mname) P.empty
CM.zipWithM_ (printSubFunctions api registry sigMap) mnames cmds
printSubFunctions :: API -> Registry -> M.Map String String ->
[String] -> [(CommandName, Command)] -> IO ()
printSubFunctions api registry sigMap mname cmds = do
let cmnt =
[Comment "Raw functions from the",
Comment "<http://www.opengl.org/registry/ OpenGL registry>."]
startModule mname (Just "{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
hRender h $ Module moduleName (P.text ("(\n" ++ separate unCommandName (map fst cmds) ++ "\n)"))
hRender h $ Import (ModuleName "Control.Monad.IO.Class") (P.text "( MonadIO(..) )")
hRender h $ Import (ModuleName "Foreign.Ptr") P.empty
hRender h $ Import (moduleNameFor ["Foreign"]) P.empty
hRender h $ Import (moduleNameFor ["Types"]) P.empty
hRender h $ Import (ModuleName "System.IO.Unsafe") (P.text "( unsafePerformIO )")
SI.hPutStrLn h ""
mapM_ (SI.hPutStrLn h . showCommand api registry sigMap . snd) cmds
type ExtensionParts = ([TypeName], [Enum'], [Command])
type ExtensionModule = (ExtensionName, ExtensionName, ExtensionParts)
printExtensionModule :: ExtensionModule -> IO ()
printExtensionModule (extName, mangledExtName, extensionParts) =
printExtension [extensionNameCategory mangledExtName, extensionNameName mangledExtName]
(Just extName)
extensionParts
extendWithProfile :: ExtensionName -> Maybe ProfileName -> ExtensionName
extendWithProfile extName =
maybe extName (\p -> extName { extensionNameName = joinWords [extensionNameName extName, capitalize (unProfileName p)]})
mangleExtensionName :: ExtensionName -> ExtensionName
mangleExtensionName extName = extName {
extensionNameCategory = fixCategory $ extensionNameCategory extName,
extensionNameName = zip (splitWords (extensionNameName extName)) [0::Integer ..] >>= fixExtensionWord }
where fixCategory c = case c of
"3DFX" -> "ThreeDFX"
_ -> c
fixExtensionWord (w, pos) = case w of
"422" | pos == 0-> "FourTwoTwo"
"64bit" -> "64Bit"
"ES2" -> "ES2"
"ES3" -> "ES3"
"FXT1" -> "FXT1"
"a2ui" -> "A2UI"
"abgr" -> "ABGR"
"astc" -> "ASTC"
"bgra" -> "BGRA"
"bptc" -> "BPTC"
"cl" -> "CL"
"cmyka" -> "CMYKA"
"dxt1" -> "DXT1"
"es" -> "ES"
"ffd" -> "FFD"
"fp64" -> "FP64"
"gpu" -> "GPU"
"hdr" -> "HDR"
"latc" -> "LATC"
"ldr" -> "LDR"
"lod" -> "LOD"
"pn" -> "PN"
"rg" -> "RG"
"rgb" -> "RGB"
"rgb10" -> "RGB10"
"rgb32" -> "RGB32"
"rgtc" -> "RGTC"
"s3tc" -> "S3TC"
"sRGB" -> "SRGB"
"snorm" -> "SNorm"
"texture3D" -> "Texture3D"
"texture4D" -> "Texture4D"
"vdpau" -> "VDPAU"
"ycbcr" -> "YCbCr"
"ycrcb" -> "YCrCb"
"ycrcba" -> "YCrCbA"
_ -> capitalize w
extensionModules :: API -> Registry -> [ExtensionModule]
extensionModules api registry =
[ (extName, mangledExtName, executeModifications api mbProfile registry mods)
| (extName, mods) <- supportedExtensions api registry
, mbProfile <- if isProfileDependent mods then suppProfs else [ Nothing ]
, let mangledExtName = mangleExtensionName (extendWithProfile extName mbProfile)
]
where suppProfs = latestProfiles api
isProfileDependent mods = any (`S.member` allProfileNames) (mentionedProfileNames mods)
mentionedProfileNames mods = DM.catMaybes . map modificationProfile $ mods
allProfileNames = S.fromList . DM.catMaybes $ suppProfs
-- We only consider non-empty supported extensions/modifications for the given API.
supportedExtensions :: API -> Registry -> [(ExtensionName, [Modification])]
supportedExtensions api registry =
[ nameAndMods
| ext <- extensions registry
, api `supports` extensionSupported ext
, nameAndMods@(_,(_:_)) <- [nameAndModifications ext] ]
where nameAndModifications :: Extension -> (ExtensionName, [Modification])
nameAndModifications e =
(extensionName e,
[ conditionalModificationModification cm
| cm <- extensionsRequireRemove e
, api `matches` conditionalModificationAPI cm
-- ARB_compatibility has an empty "require" element only
, not . null . modificationInterfaceElements . conditionalModificationModification $ cm ])
extensionHyperlink :: ExtensionName -> String
extensionHyperlink n =
"<https://www.opengl.org/registry/specs/" ++
fixRegistryPath (extensionNameCategory n ++ "/" ++ extensionNameName n) ++ ".txt " ++
joinWords [extensionNameCategory n, extensionNameName n] ++ ">"
where fixRegistryPath :: String -> String
fixRegistryPath path = case path of
"3DFX/multisample" -> "3DFX/3dfx_multisample"
"EXT/debug_label" -> "EXT/EXT_debug_label"
"EXT/debug_marker" -> "EXT/EXT_debug_marker"
"EXT/multisample" -> "EXT/wgl_multisample"
"EXT/texture_cube_map" -> "ARB/texture_cube_map"
"INGR/blend_func_separate" -> "EXT/blend_func_separate"
"KHR/blend_equation_advanced_coherent" -> "KHR/blend_equation_advanced"
"KHR/texture_compression_astc_ldr" -> "KHR/texture_compression_astc_hdr"
"NV/blend_equation_advanced_coherent" -> "NV/blend_equation_advanced"
"NVX/conditional_render" -> "NVX/nvx_conditional_render"
"OES/byte_coordinates" -> "OES/OES_byte_coordinates"
"OES/compressed_paletted_texture" -> "OES/OES_compressed_paletted_texture"
"OES/fixed_point" -> "OES/OES_fixed_point"
"OES/query_matrix" -> "OES/OES_query_matrix"
"OES/read_format" -> "OES/OES_read_format"
"OES/single_precision" -> "OES/OES_single_precision"
"SGIS/fog_function" -> "SGIS/fog_func"
"SGIS/point_parameters" -> "EXT/point_parameters"
"SGIX/fragment_lighting" -> "EXT/fragment_lighting"
"SGIX/pixel_texture" -> "SGIX/sgix_pixel_texture"
"SGIX/texture_add_env" -> "SGIX/texture_env_add"
_ -> path
printReExports :: [ExtensionModule] -> IO ()
printReExports extModules = do
let extMap = M.fromListWith (++) [((extensionNameCategory extName, extensionNameCategory mangledExtName), [mangledExtName])
| (extName, mangledExtName, _) <- extModules ]
reExports = [ (cat, L.sort mangledExtNames)
| (cat, mangledExtNames) <- M.toList extMap ]
CM.forM_ reExports $ \((category, mangledCategory), mangledExtNames) -> do
let cmnt = [Comment ("A convenience module, combining all raw modules containing " ++ category ++ " extensions.")]
startModule [mangledCategory] Nothing cmnt $ \moduleName h -> do
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\mangledExtName -> "module " ++ (case extensionNameFor mangledExtName of ModuleName mn -> mn)) mangledExtNames ++ "\n)"))
CM.forM_ mangledExtNames $ \mangledExtName ->
hRender h $ Import (extensionNameFor mangledExtName) P.empty
printExtensionSupport :: [ExtensionModule] -> IO ()
printExtensionSupport extModules = do
let cmnt = [Comment "Extension support predicates."]
startModule ["ExtensionPredicates"] (Just "{-# OPTIONS_HADDOCK hide #-}") cmnt $ \moduleName h -> do
hRender h $ Module moduleName P.empty
hRender h $ Import (ModuleName "Control.Monad.IO.Class") (P.text "( MonadIO(..) )")
hRender h $ Import (ModuleName "Data.Set") (P.text "( member )")
hRender h $ Import (moduleNameFor ["GetProcAddress"]) (P.text "( getExtensions, extensions )")
let names = sortUnique [ extName | (extName, _, _) <- extModules]
CM.forM_ names $ \extName -> do
let predNameMonad = extensionPredicateNameMonad extName
predName = extensionPredicateName extName
extString = joinWords [ extensionNameAPI extName
, extensionNameCategory extName
, extensionNameName extName ]
SI.hPutStrLn h $ ""
hRender h $ Comment ("| Is the " ++ extensionHyperlink extName ++ " extension supported?")
SI.hPutStrLn h $ predNameMonad ++ " :: MonadIO m => m Bool"
SI.hPutStrLn h $ predNameMonad ++ " = getExtensions >>= (return . member " ++ show extString ++ ")"
SI.hPutStrLn h $ ""
hRender h $ Comment ("| Is the " ++ extensionHyperlink extName ++ " extension supported?")
hRender h $ Comment "Note that in the presence of multiple contexts with different capabilities,"
hRender h $ Comment ("this might be wrong. Use '" ++ predNameMonad ++ "' in those cases instead.")
SI.hPutStrLn h $ predName ++ " :: Bool"
SI.hPutStrLn h $ predName ++ " = member " ++ show extString ++ " extensions"
SI.hPutStrLn h $ "{-# NOINLINE " ++ predName ++ " #-}"
extensionNameFor :: ExtensionName -> ModuleName
extensionNameFor mangledExtName = moduleNameFor [extensionNameCategory mangledExtName, extensionNameName mangledExtName]
supports :: API -> Maybe [API] -> Bool
_ `supports` Nothing = True
a `supports` Just apis = a `elem` apis
capitalize :: String -> String
capitalize str = C.toUpper (head str) : map C.toLower (tail str)
separate :: (a -> String) -> [a] -> String
separate f = L.intercalate ",\n" . map (" " ++) . map f
-- Note that we handle features just like extensions.
printExtension :: [String] -> Maybe ExtensionName -> ExtensionParts -> IO ()
printExtension moduleNameSuffix mbExtName (ts, es, cs) = do
let pragma = if null es then Nothing else Just "{-# LANGUAGE PatternSynonyms #-}"
startModule moduleNameSuffix pragma [] $ \moduleName h -> do
let extStr = flip (maybe "") mbExtName $ \extName ->
" -- * Extension Support\n" ++
separate id [ extensionPredicateNameMonad extName
, extensionPredicateName extName ] ++ ",\n"
typeStr | null ts = ""
| otherwise = " -- * Types\n" ++
separate unTypeName ts ++
if null es && null cs then "\n" else ",\n"
enumStr | null es = ""
| otherwise = " -- * Enums\n" ++
separate (("pattern " ++) . unEnumName . enumName) es ++
if null cs then "\n" else ",\n"
funcStr | null cs = ""
| otherwise = " -- * Functions\n" ++
separate (unCommandName . commandName) cs ++
"\n"
hRender h $ Module moduleName (P.text ("(\n" ++ extStr ++ typeStr ++ enumStr ++ funcStr ++ ")"))
CM.when (DM.isJust mbExtName) $
hRender h $ Import (moduleNameFor ["ExtensionPredicates"]) P.empty
CM.unless (null ts) $
hRender h $ Import (moduleNameFor ["Types"]) P.empty
CM.unless (null es) $
hRender h $ Import (moduleNameFor ["Tokens"]) P.empty
CM.unless (null cs) $
hRender h $ Import (moduleNameFor ["Functions"]) P.empty
extensionPredicateName :: ExtensionName -> String
extensionPredicateName extName =
joinWords [ map C.toLower (extensionNameAPI extName)
, extensionNameCategory extName
, extensionNameName extName ]
extensionPredicateNameMonad :: ExtensionName -> String
extensionPredicateNameMonad extName =
map C.toLower (extensionNameAPI mangledExtName) ++
"Get" ++
extensionNameCategory mangledExtName ++
extensionNameName mangledExtName
where mangledExtName = mangleExtensionName extName
printTopLevel :: API -> [ExtensionModule] -> IO ()
printTopLevel api extModules = do
let mangledCategories = sortUnique [ extensionNameCategory mangledExtName
| (_, mangledExtName, _) <- extModules ]
profToReExport = profileToReExport api
lastComp = featureName (latestVersion api) profToReExport
moduleNames = [ moduleNameFor [c] | c <- [ lastComp, "GetProcAddress" ] ++ mangledCategories ]
cmnt = [ Comment (L.intercalate " "
[ "A convenience module, combining the latest"
, apiName api
, maybe "version" (\p -> unProfileName p ++ " profile") profToReExport
, "plus" ])
, Comment "all extensions." ]
startModule [] Nothing cmnt $ \moduleName h -> do
hRender h $ Module moduleName (P.text ("(\n" ++ separate (\(ModuleName m) -> "module " ++ m) moduleNames ++ "\n)"))
CM.forM_ moduleNames $ \theModuleName ->
hRender h $ Import theModuleName P.empty
apiName :: API -> String
apiName api = case unAPI api of
"gl" -> "OpenGL"
"gles1" -> "OpenGL ES 1.x"
"gles2" -> "OpenGL ES"
a -> error $ "unknown API " ++ a
sortUnique :: Ord a => [a] -> [a]
sortUnique = S.toList . S.fromList
startModule :: [String] -> Maybe String -> [Comment] -> (ModuleName -> SI.Handle -> IO ()) -> IO ()
startModule moduleNameSuffix mbPragma comments action = do
let path = modulePathFor moduleNameSuffix
moduleName = moduleNameFor moduleNameSuffix
D.createDirectoryIfMissing True $ F.takeDirectory path
SI.withFile path SI.WriteMode $ \h -> do
printModuleHeader h mbPragma moduleName comments
action moduleName h
moduleNameFor :: [String] -> ModuleName
moduleNameFor = ModuleName . L.intercalate "." . moduleNameParts
modulePathFor :: [String] -> FilePath
modulePathFor moduleNameSuffix = F.joinPath (moduleNameParts moduleNameSuffix) `F.addExtension` "hs"
moduleNameParts :: [String] -> [String]
moduleNameParts = (["Graphics", "GL"] ++)
printModuleHeader :: SI.Handle -> Maybe String -> ModuleName -> [Comment] -> IO ()
printModuleHeader h mbPragma (ModuleName moduleName) comments = do
maybe (return ()) (SI.hPutStrLn h) mbPragma
hRender h $ Comment "------------------------------------------------------------------------------"
hRender h $ Comment "|"
hRender h $ Comment ("Module : " ++ moduleName)
hRender h $ Comment "Copyright : (c) Sven Panne 2016"
hRender h $ Comment "License : BSD3"
hRender h $ Comment ""
hRender h $ Comment "Maintainer : Sven Panne <svenpanne@gmail.com>"
hRender h $ Comment "Stability : stable"
hRender h $ Comment "Portability : portable"
hRender h $ Comment ""
CM.unless (null comments) $ do
mapM_ (hRender h) comments
hRender h $ Comment ""
hRender h $ Comment "------------------------------------------------------------------------------"
SI.hPutStrLn h ""
-- Annoyingly enough, the OpenGL registry doesn't contain any enums for
-- OpenGL 1.0, so let's just use the OpenGL 1.1 ones. Furthermore, features
-- don't explicitly list the types referenced by commands, so we add them.
fixedReplay :: API -> Version -> Maybe ProfileName -> Registry -> ExtensionParts
fixedReplay api version mbProfile registry
| api == API "gl" && version == read "1.0" = (ts', es11, cs)
| otherwise = (ts', es, cs)
where (ts, es, cs) = replay api version mbProfile registry
(_, es11, _) = replay api (read "1.1") mbProfile registry
ts' = S.toList . addFuncsAndMakes . S.unions $ S.fromList ts : map referencedTypes cs
-- For debug callbacks, we want to export the Haskell types and their creators, too.
addFuncsAndMakes :: S.Set TypeName -> S.Set TypeName
addFuncsAndMakes =
flip (foldr addFuncAndMake) [
"GLDEBUGPROC",
"GLDEBUGPROCAMD",
"GLDEBUGPROCARB",
"GLDEBUGPROCKHR" ]
where addFuncAndMake t ts
| TypeName t `S.member` ts =
ts `S.union` S.fromList (map TypeName [ t ++ "Func", "make" ++ t ])
| otherwise = ts
-- Here is the heart of the feature construction logic: Chronologically replay
-- the whole version history for the given API/version/profile triple.
replay :: API -> Version -> Maybe ProfileName -> Registry -> ExtensionParts
replay api version mbProfile registry =
executeModifications api mbProfile registry modifications
where modifications = history >>= flip lookup' (features registry)
history = L.sort [ key
| key@(a,v) <- M.keys (features registry)
, a == api
, v <= version ]
executeModifications :: API -> Maybe ProfileName -> Registry -> [Modification] -> ExtensionParts
executeModifications api mbProfile registry modifications = (ts, es, cs)
where ts = [ n | TypeElement n <- lst ]
es = [ e | EnumElement n <- lst
, e <- lookup' n (enums registry)
, api `matches` enumAPI e ]
cs = [ lookup' n (commands registry) | CommandElement n <- lst ]
lst = S.toList $ interfaceElementsFor mbProfile modifications
interfaceElementsFor :: Maybe ProfileName -> [Modification] -> S.Set InterfaceElement
interfaceElementsFor mbProfile modifications =
foldl (flip ($)) S.empty modificationsFor
where modificationsFor =
[ op (modificationKind m) ie
| m <- modifications
, maybe True (`matches` modificationProfile m) mbProfile
, ie <- modificationInterfaceElements m ]
op Require = S.insert
op Remove = S.delete
lookup' :: (Ord k, Show k) => k -> M.Map k a -> a
lookup' k m = M.findWithDefault (error ("unknown name " ++ show k)) k m
matches :: Eq a => a -> Maybe a -> Bool
_ `matches` Nothing = True
s `matches` Just t = s == t
convertEnum :: Enum' -> [String]
convertEnum e =
[ "pattern " ++ n ++ " = " ++ unEnumValue (enumValue e) ++ " :: " ++ unTypeName (enumType e) ]
where n = unEnumName . enumName $ e
showCommand :: API -> Registry -> M.Map String String -> Command -> String
showCommand api registry sigMap c =
showString (P.render (P.pPrint (Comment (take 77 (name ++ " " ++ repeat '-'))) P.$+$ P.text "" P.$+$ P.text "")) .
showString (P.render cmnt) .
showString (name ++ "\n") .
showString (" :: MonadIO m\n") .
showString (" => " ++ signature True) .
showString (name ++ args ++ " = liftIO $ " ++ dyn_name ++ " " ++ ptr_name ++ args ++ "\n\n") .
showString ("{-# NOINLINE " ++ ptr_name ++ " #-}\n") .
showString (ptr_name ++ " :: FunPtr (" ++ compactSignature ++ ")\n") .
showString (ptr_name ++ " = unsafePerformIO $ getCommand " ++ str_name ++ "\n") .
id $ ""
where name = signatureElementName (resultType c)
dyn_name = lookup' compactSignature sigMap
ptr_name = "ptr_" ++ name
str_name = show name
compactSignature = signature False
signature withComment = showSignatureFromCommand registry c withComment
urls = M.findWithDefault [] (api, CommandName name) manPageURLs
links = L.intercalate " or " (map renderURL urls)
cmnt = case concat (man ++ ve ++ al) of
"" -> P.empty
cs -> P.pPrint (Comment ("|" ++ cs)) P.$+$ P.text ""
man = case urls of
[] -> []
[_] -> [" Manual page for " ++ links ++ "."]
_ -> [" Manual pages for " ++ links ++ "."]
ve = [ " The vector equivalent of this command is '" ++ unCommandName v ++ "'." | Just v <- [vecEquiv c] ]
al = [ " This command is an alias for '" ++ unCommandName a ++ "'." | Just a <- [alias c] ]
renderURL (u, l) = "<" ++ u ++ " " ++ l ++ ">"
args = [1 .. length (paramTypes c)] >>= \i -> " v" ++ show i
makeImportDynamic :: String -> String -> String
makeImportDynamic compactSignature dyn_name =
"foreign import CALLCONV \"dynamic\" " ++ dyn_name ++ "\n" ++
" :: FunPtr (" ++ compactSignature ++ ")\n" ++
" -> " ++ compactSignature ++ "\n"
showSignatureFromCommand :: Registry -> Command -> Bool -> String
showSignatureFromCommand registry c withComment =
L.intercalate ((if withComment then " " else "") ++ " -> ")
([showSignatureElement registry withComment False t | t <- paramTypes c] ++
[showSignatureElement registry withComment True (resultType c)])
showSignatureElement :: Registry -> Bool -> Bool -> SignatureElement -> String
showSignatureElement registry withComment isResult sigElem = el ++ cmnt
where el | isResult = monad ++ " " ++ showsPrec 11 sigElem ""
| otherwise = show sigElem
monad | withComment = "m"
| otherwise = "IO"
cmnt | withComment = P.render (showComment registry name sigElem P.$+$ P.text "")
| otherwise = ""
name | isResult = ""
| otherwise = signatureElementName sigElem
showComment :: Registry -> String -> SignatureElement -> P.Doc
showComment registry name sigElem
| null name' && null info = P.text ""
| otherwise = P.text " " P.<> P.pPrint (Comment ("^" ++ name' ++ info ++ "."))
where name' | null name = ""
| otherwise = " " ++ inlineCode name
info | isInteresting = elms ++ " of type " ++ hurz
| otherwise = ""
-- Alas, there are tons of group names which are referenced, but never
-- defined, so we have to leave them without a link.
-- TODO: Do not use Show instance for SignatureElement.
hurz = case belongsToGroup sigElem of
Just gn | numPointer sigElem <= 1 &&
fgn `M.member` groups registry -> linkToGroup fgn
where fgn = fixGroupName gn
_ -> inlineCode (show (base sigElem))
isInteresting = DM.isJust (arrayLength sigElem) || DM.isJust (belongsToGroup sigElem)
elms | numPointer sigElem > 0 = " pointing to" ++ len ++ " " ++ elements
| otherwise = ""
elements | arrayLength sigElem == Just "1" = "element"
| otherwise = "elements"
len = maybe "" (\l -> " " ++ inlineCode l) (arrayLength sigElem)
base = maybeDeref . maybeSetBaseType
maybeDeref e | numPointer e > 0 = e{numPointer = numPointer e - 1}
| otherwise = e
maybeSetBaseType e = maybe e (\g -> e{baseType = TypeName (unGroupName g)}) (belongsToGroup e)
fixGroupName :: GroupName -> GroupName
fixGroupName g
| g == GroupName "PixelInternalFormat" = GroupName "InternalFormat"
| g == GroupName "SGIXFfdMask" = GroupName "FfdMaskSGIX"
| otherwise = g
-- TODO: This is very fragile, but currently there is no clean way to specify
-- link texts when referencing anchors in Haddock.
linkToGroup :: GroupName -> String
linkToGroup g = "[" ++ n ++ "](" ++ htmlFilenameFor ["Groups"] ++ "#" ++ n ++ ")"
where n = unGroupName g
htmlFilenameFor :: [String] -> String
htmlFilenameFor = (++ ".html") . L.intercalate "-" . moduleNameParts
inlineCode :: String -> String
inlineCode s = "@" ++ s ++ "@"
-- TODO: Use Either instead of error below?
toEnumType :: ToEnumType
toEnumType eNamespace eGroup eType suffix eName = TypeName $
case (eNamespace, eGroup, eType, unTypeSuffix `fmap` suffix, eName) of
-- glx.xml
(Just "GLXStrings", _, _, _, _) -> "String"
(Just ('G':'L':'X':_), _, _, _, _) -> "CInt"
-- egl.xml
-- TODO: EGLenum for EGL_OPENGL_API, EGL_OPENGL_ES_API, EGL_OPENVG_API, EGL_OPENVG_IMAGE?
(Just ('E':'G':'L':_), _, Nothing, Just "ull", _) -> "EGLTime"
(Just ('E':'G':'L':_), _, _, _, _) -> "EGLint"
-- wgl.xml
(Just "WGLLayerPlaneMask", _, _, _, _) -> "UINT"
(Just "WGLColorBufferMask", _, _, _, _) -> "UINT"
(Just "WGLContextFlagsMask", _, _, _, _) -> "INT"
(Just "WGLContextProfileMask", _, _, _, _) -> "INT"
(Just "WGLImageBufferMaskI3D" , _, _, _, _) -> "UINT"
(Just "WGLDXInteropMaskNV", _, _, _, _) -> "GLenum"
(Just ('W':'G':'L':_), _, _, _, _) -> "CInt"
-- gl.xml
(Just "OcclusionQueryEventMaskAMD", _, _, _, _) -> "GLuint"
(Just "GL", Just "SpecialNumbers", _, _, "GL_FALSE") -> "GLboolean"
(Just "GL", Just "SpecialNumbers", _, _, "GL_TRUE") -> "GLboolean"
(Just "GL", Just "PathRenderingTokenNV", _, _, _) -> "GLubyte"
(Just "GL", _, Just "bitmask", _, _) -> "GLbitfield"
(Just "GL", _, Nothing, Just "u", _) -> "GLuint"
(Just "GL", _, Nothing, Just "ull", _) -> "GLuint64"
(Just "GL", _, Nothing, Nothing, _) -> "GLenum"
(_, _, _, _, _) -> error "can't determine enum type"
isMask :: TypeName -> Bool
isMask = (== TypeName "GLbitfield")
--------------------------------------------------------------------------------
data Module = Module ModuleName Exports
instance P.Pretty Module where
pPrint (Module mn ex) = P.text "module" P.<+> P.pPrint mn P.<+> ex P.<+> P.text "where\n"
type Exports = P.Doc
data Import = Import ModuleName ImportSpecs
instance P.Pretty Import where
pPrint (Import mn im) = P.text "import" P.<+> P.pPrint mn P.<+> im
type ImportSpecs = P.Doc
newtype ModuleName = ModuleName String
instance P.Pretty ModuleName where
pPrint (ModuleName m) = P.text m
newtype Comment = Comment String
instance P.Pretty Comment where
pPrint (Comment c) | null c = P.text "--"
| all (== '-') c = P.pPrint (Comment "") P.<> P.text c
| otherwise = P.pPrint (Comment "") P.<+> P.text c
hRender :: P.Pretty a => SI.Handle -> a -> IO ()
hRender h = SI.hPutStrLn h . P.render . P.pPrint