OpenGLRaw-2.1.0.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 as M
import qualified Data.Maybe as DM
import qualified Data.Set as S
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
[registryPath] <- E.getArgs
let api = API "gl"
res <- fmap parseRegistry $ readFile registryPath
case res of
Left msg -> SI.hPutStrLn SI.stderr msg
Right registry -> do
printTokens api registry
printFunctions api registry
printExtensions api registry
CM.forM_ ["1.0", "1.1", "1.2", "1.3", "1.4", "1.5", "2.0", "2.1"] $ \v ->
printFeature api (read v) (ProfileName "version") registry
CM.forM_ ["3.0", "3.1", "3.2", "3.3", "4.0", "4.1", "4.2", "4.3", "4.4", "4.5"] $ \v -> do
printFeature api (read v) (ProfileName "core") registry
printFeature api (read v) (ProfileName "compatibility") registry
printFeature :: API -> Version -> ProfileName -> Registry -> IO ()
printFeature api version profile registry = do
let relName = capitalize (unProfileName profile) ++
show (major version) ++ show (minor version)
printExtension Nothing [relName] $ fixedReplay api version profile registry
printTokens :: API -> Registry -> IO ()
printTokens api registry = do
let comment =
["All enumeration tokens from the",
"<http://www.opengl.org/registry/ OpenGL registry>."]
startModule Nothing ["Tokens"] Nothing comment $ \moduleName h -> do
SI.hPutStrLn h $ "module " ++ moduleName ++ " where"
SI.hPutStrLn h ""
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.Types"
SI.hPutStrLn h ""
mapM_ (SI.hPutStrLn h . unlines . convertEnum)
[ e
| es <- M.elems (enums registry)
, e <- es
, api `matches` enumAPI e ]
printFunctions :: API -> Registry -> IO ()
printFunctions api registry = do
let comment =
["All raw functions from the",
"<http://www.opengl.org/registry/ OpenGL registry>."]
startModule Nothing ["Functions"] (Just "{-# LANGUAGE CPP #-}") comment $ \moduleName h -> do
SI.hPutStrLn h $ "module " ++ moduleName ++ " ("
SI.hPutStrLn h . separate unCommandName . M.keys . commands $registry
SI.hPutStrLn h ") where"
SI.hPutStrLn h ""
SI.hPutStrLn h "import Foreign.C.Types"
SI.hPutStrLn h "import Foreign.Marshal.Error ( throwIf )"
SI.hPutStrLn h "import Foreign.Ptr ( Ptr, FunPtr, nullFunPtr )"
SI.hPutStrLn h "import System.IO.Unsafe ( unsafePerformIO )"
SI.hPutStrLn h ""
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.GetProcAddress ( getProcAddress )"
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.Types"
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 ""
SI.hPutStrLn h "throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)"
SI.hPutStrLn h "throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
SI.hPutStrLn h ""
mapM_ (SI.hPutStrLn h . showCommand api) (M.elems (commands registry))
printExtensions :: API -> Registry -> IO ()
printExtensions api registry = do
-- only consider non-empty supported extensions/modifications for the given API
let supportedExtensions =
[ nameAndMods
| ext <- extensions registry
, api `supports` extensionSupported ext
, nameAndMods@(_,(_:_)) <- [nameAndModifications api ext] ]
CM.forM_ supportedExtensions $ \(n,mods) -> do
let profileAndModName =
if any isProfileDependent mods
then [(ProfileName p, extendExtensionName n p)
| p <- ["core", "compatibility"] ]
else [(ProfileName "core", n)] -- the actual profile doesn't matter
CM.forM_ profileAndModName $ \(prof, modName) -> do
let ("GL":vendor:extWords) = splitBy (== '_') (unExtensionName modName)
printExtension (Just vendor) extWords $
executeModifications api prof registry mods
isProfileDependent :: Modification -> Bool
isProfileDependent = DM.isJust . modificationProfile
extendExtensionName :: ExtensionName -> String -> ExtensionName
extendExtensionName n profile =
ExtensionName . (++ ("_" ++ profile)). unExtensionName $ n
startModule :: Maybe String -> [String] -> Maybe String -> [String] -> (String -> SI.Handle -> IO ()) -> IO ()
startModule mbVendor extWords mbPragma comments action = do
let moduleNameParts =
["Graphics", "Rendering", "OpenGL", "Raw"] ++
maybe [] (\vendor -> [fixVendor vendor]) mbVendor ++
[concat (zipWith fixExtensionWord extWords [0 ..])]
path = F.joinPath moduleNameParts `F.addExtension` "hs"
moduleName = L.intercalate "." moduleNameParts
D.createDirectoryIfMissing True $ F.takeDirectory path
SI.withFile path SI.WriteMode $ \h -> do
printModuleHeader h mbPragma moduleName comments
action moduleName h
fixVendor :: String -> String
fixVendor v = case v of
"3DFX" -> "ThreeDFX"
_ -> v
fixExtensionWord :: String -> Int -> String
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
nameAndModifications :: API -> Extension -> (ExtensionName, [Modification])
nameAndModifications api e =
(extensionName e,
[ conditionalModificationModification cm
| cm <- extensionsRequireRemove e
, api `matches` conditionalModificationAPI cm ])
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 :: Maybe String -> [String] -> ([TypeName], [Enum'], [Command]) -> IO ()
printExtension mbVendor extWords (ts, es, cs) = do
let comment = maybe [] (makeExtensionURL extWords) mbVendor
startModule mbVendor extWords Nothing comment $ \moduleName h -> do
SI.hPutStrLn h $ "module "++ moduleName ++ " ("
CM.unless (null ts) $ do
SI.hPutStrLn h " -- * Types"
SI.hPutStr h $ separate unTypeName ts
SI.hPutStrLn h $ if null es && null cs then "" else ","
CM.unless (null es) $ do
SI.hPutStrLn h " -- * Enums"
SI.hPutStr h $ separate (unEnumName . enumName) es
SI.hPutStrLn h $ if null cs then "" else ","
CM.unless (null cs) $ do
SI.hPutStrLn h " -- * Functions"
SI.hPutStr h $ separate (unCommandName . commandName) cs
SI.hPutStrLn h ""
SI.hPutStrLn h ") where"
SI.hPutStrLn h ""
CM.unless (null ts) $
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.Types"
CM.unless (null es) $
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.Tokens"
CM.unless (null cs) $
SI.hPutStrLn h "import Graphics.Rendering.OpenGL.Raw.Functions"
makeExtensionURL :: [String] -> String -> [String]
makeExtensionURL extWords vendor =
["The <https://www.opengl.org/registry/specs/" ++
vendor ++ "/" ++ L.intercalate "_" extWords ++ ".txt " ++
L.intercalate "_" (vendor : extWords) ++ "> extension."]
printModuleHeader :: SI.Handle -> Maybe String -> String -> [String] -> IO ()
printModuleHeader h mbPragma moduleName comments = do
maybe (return ()) (SI.hPutStrLn h) mbPragma
SI.hPutStrLn h "--------------------------------------------------------------------------------"
SI.hPutStrLn h "-- |"
SI.hPutStrLn h $ "-- Module : " ++ moduleName
SI.hPutStrLn h "-- Copyright : (c) Sven Panne 2015"
SI.hPutStrLn h "-- License : BSD3"
SI.hPutStrLn h "--"
SI.hPutStrLn h "-- Maintainer : Sven Panne <svenpanne@gmail.com>"
SI.hPutStrLn h "-- Stability : stable"
SI.hPutStrLn h "-- Portability : portable"
SI.hPutStrLn h "--"
CM.unless (null comments) $ do
mapM_ (SI.hPutStrLn h . ("-- " ++)) comments
SI.hPutStrLn h "--"
SI.hPutStrLn h "--------------------------------------------------------------------------------"
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 -> ProfileName -> Registry -> ([TypeName], [Enum'], [Command])
fixedReplay api version profile registry
| api == API "gl" && version == read "1.0" = (ts', es11, cs)
| otherwise = (ts', es, cs)
where (ts, es, cs) = replay api version profile registry
(_, es11, _) = replay api (read "1.1") profile registry
ts' = S.toList . S.unions $ S.fromList ts : map referencedTypes cs
-- 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 -> ProfileName -> Registry -> ([TypeName], [Enum'], [Command])
replay api version profile registry =
executeModifications api profile registry modifications
where modifications = concatMap modificationsFor history
modificationsFor = flip lookup' (features registry)
history = L.sort [ key
| key@(a,v) <- M.keys (features registry)
, a == api
, v <= version ]
executeModifications :: API -> ProfileName -> Registry -> [Modification] -> ([TypeName], [Enum'], [Command])
executeModifications api profile 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 profile modifications
interfaceElementsFor :: ProfileName -> [Modification] -> S.Set InterfaceElement
interfaceElementsFor profile modifications =
foldl (flip ($)) S.empty modificationsFor
where modificationsFor =
[ op (modificationKind m) ie
| m <- modifications
, profile `matches` modificationProfile m
, 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 =
[ n ++ " :: " ++ unTypeName (enumType e)
, n ++ " = " ++ unEnumValue (enumValue e) ]
where n = unEnumName . enumName $ e
showCommand :: API -> Command -> String
showCommand api c =
showString (take 80 ("-- " ++ name ++ " " ++ repeat '-') ++ "\n\n") .
showString man .
showString (name ++ "\n") .
showString (" :: " ++ signature True) .
showString (name ++ " = " ++ dyn_name ++ " " ++ ptr_name ++ "\n\n") .
showString ("foreign import CALLCONV \"dynamic\" " ++ dyn_name ++ "\n" ++
" :: FunPtr (" ++ compactSignature ++ ")\n" ++
" -> " ++ compactSignature ++ "\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 = "dyn_" ++ name
ptr_name = "ptr_" ++ name
str_name = show name
compactSignature = signature False
signature withComment =
L.intercalate ((if withComment then " " else "") ++ " -> ")
([showSignatureElement withComment False t | t <- paramTypes c] ++
[showSignatureElement withComment True (resultType c)])
urls = M.findWithDefault [] (api, CommandName name) manPageURLs
links = L.intercalate " or " (map renderURL urls) ++ "\n"
man = case urls of
[] -> ""
[_] -> "-- | Manual page for " ++ links
_ -> "-- | Manual pages for " ++ links
renderURL (u, l) = "<" ++ u ++ " " ++ l ++ ">"
showSignatureElement :: Bool -> Bool -> SignatureElement -> String
showSignatureElement withComment isResult sigElem = el ++ comment
where el | isResult = "IO " ++ showsPrec 11 sigElem ""
| otherwise = show sigElem
comment | withComment = showComment name sigElem
| otherwise = ""
name | isResult = ""
| otherwise = signatureElementName sigElem
showComment :: String -> SignatureElement -> String
showComment name sigElem
| null name' && null info = "\n"
| otherwise = " -- ^" ++ name' ++ info ++ ".\n"
where name' | null name = ""
| otherwise = " " ++ inlineCode name
info | isInteresting = elms ++ " of type " ++ inlineCode (show (base sigElem))
| otherwise = ""
isInteresting = DM.isJust (arrayLength sigElem) || DM.isJust (belongsToGroup sigElem)
elms | numPointer sigElem > 0 = " pointing to" ++ len ++ " elements"
| otherwise = ""
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)
inlineCode :: String -> String
inlineCode s = "@" ++ s ++ "@"