Permalink
Browse files

Switch to the new OpenGLRawInterface package.

  • Loading branch information...
1 parent b02f6b8 commit 2f6aa766564314a9cc49f09f2d05d16104247545 @Laar committed Mar 24, 2013
View
@@ -43,7 +43,8 @@ executable OpenGLRawgen
opengl-api -any,
parsec -any,
xml,
- OpenGLRawgenBase
+ OpenGLRawgenBase,
+ OpenGLRawInterface
ghc-options: -Wall -O2 -rtsopts
ghc-shared-options:
ghc-prof-options: -Wall -O2 -rtsopts -prof -auto-all -caf-all
View
Binary file not shown.
View
@@ -1,83 +1,49 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
module Interface.Module (
- moduleToRenderedInterface,
- moduleToInterface
+ moduleToInterface, writeModuleInterface,
+ writePackageInterface,
) where
-import Language.Haskell.Exts.Syntax hiding (QName)
-import Code.Generating.Utils
-import Data.String
-import Text.XML.Light
+import Language.Haskell.Exts.Syntax
+import Data.List
+import qualified Data.Set as S
-import Modules.Types
-
-moduleToRenderedInterface :: RawModule -> String
-moduleToRenderedInterface = ppTopElement . moduleToInterface
-
-moduleToInterface :: RawModule -> Element
-moduleToInterface rawMod =
- node "moduledefinition"
- ([Attr "module" . moduleNameToName $ rawModuleName rawMod
- , Attr "exported" $ if externalRawModule rawMod then "True" else "False"
- ], parts)
- where
- parts = node "parts"
- . map modulePartToElement $ rawModuleParts rawMod
-
-modulePartToElement :: ModulePart -> Element
-modulePartToElement p = case p of
- DefineEnum n gln t _ -> enumElem n gln t
- ReDefineLEnum n gln t _ -> enumElem n gln t
- ReDefineIEnum n gln t _ -> enumElem n gln t
- ReExport (n, m) gln -> reExportElem n gln m
- DefineFunc n rt ats gln _ -> functionElem n gln rt ats
- ReExportModule m -> moduleReexport m
-
--- To make constructing xml easier
-instance IsString QName where
- fromString = unqual
+import Language.OpenGLRaw.Interface.Serialize
+import Language.OpenGLRaw.Interface.Types
-functionElem :: Name -> GLName -> FType -> [FType] -> Element
-functionElem name glname rettype argtypes =
- node "function"
- ([ Attr "glname" glname
- , Attr "name" $ unname name
- ], typeContents)
- where
- typeContents =
- node "return" (toElem rettype)
- : map toArgElem argtypes
- toArgElem = node "argument" . toElem
- toElem :: FType -> Element
- toElem (TCon n) = node "con" [Attr "type" n]
- toElem TVar = node "var" ()
- toElem (TPtr ft) = node "ptr" $ toElem ft
- toElem UnitTCon = node "unit" ()
+import Main.Monad
+import Main.Options
+import Modules.Types
-enumElem :: Name -> GLName -> ValueType -> Element
-enumElem name glname vt =
- node "enum"
- [ Attr "glname" glname
- , Attr "name" $ unname name
- , Attr "type" valType
- ]
+writePackageInterface :: [RawModule] -> RawGenIO ()
+writePackageInterface modus = do
+ let inter = OpenGLRawI . S.fromList $ map rawModuleName modus
+ path <- asksOptions interfaceDir
+ liftIO $ writePackage path inter
+
+writeModuleInterface :: RawModule -> RawGenIO ()
+writeModuleInterface modu = do
+ path <- asksOptions interfaceDir
+ liftIO . writeModule path $ moduleToInterface modu
+
+moduleToInterface :: RawModule -> ModuleI
+moduleToInterface rm =
+ let baseModule
+ = ModuleI
+ (rawModuleName rm) (rawModuleType rm)
+ S.empty S.empty S.empty
+ in foldl' (flip addModulePart) baseModule $ rawModuleParts rm
+
+addModulePart :: ModulePart -> ModuleI -> ModuleI
+addModulePart p m = case p of
+ DefineEnum n gln t _ -> addEnum $ EnumI gln (unName n) t
+ ReDefineLEnum n gln t _ -> addEnum $ EnumI gln (unName n) t
+ ReDefineIEnum n gln t _ -> addEnum $ EnumI gln (unName n) t
+ ReExport (n,m') _ -> addReExport $ SingleExport m' (unName n)
+ DefineFunc n rt ats gln _ -> addFunc $ FuncI gln (unName n) rt ats
+ ReExportModule m' -> addReExport $ ModuleExport m'
where
- valType = case vt of
- EnumValue -> "enum"
- BitfieldValue -> "bitfield"
-
-reExportElem :: Name -> GLName -> ModuleName -> Element
-reExportElem name glname (ModuleName modName) =
- node "reexported"
- [ Attr "glname" glname
- , Attr "name" $ unname name
- , Attr "module" modName
- ]
-
-moduleReexport :: ModuleName -> Element
-moduleReexport (ModuleName modName) =
- node "exportedmodule"
- [ Attr "module" modName]
-
-
+ addEnum e = m{modEnums = S.insert e $ modEnums m}
+ addFunc f = m{modFuncs = S.insert f $ modFuncs m}
+ addReExport r = m{modReExports = S.insert r $ modReExports m}
+ unName (Ident i) = i
+ unName (Symbol s) = s
View
@@ -92,24 +92,24 @@ outputModules :: [RawModule] -> RawGenIO ()
outputModules modules = do
logMessage $ "Writing " ++ show (length modules) ++ " modules"
F.forM_ modules $ outputModule
- let (exts, ints) = partition externalRawModule modules
+ let (exts, ints) = partition isExternal modules
oDir <- asksOptions outputDir
logMessage "Writing modulelistings"
writeModuleListing (oDir </> "modulesE.txt") exts
writeModuleListing (oDir </> "modulesI.txt") ints
+ -- writing the interface listing
+ writePackageInterface modules
outputModule :: RawModule -> RawGenIO ()
outputModule rmodule = do
let mname = rawModuleName rmodule
modu <- toModule rmodule
oDir <- asksOptions outputDir
let modu' = replaceCallConv "CALLCONV" $ prettyPrint modu
- interf = moduleToRenderedInterface rmodule
path = oDir </> moduleNameToPath mname ++ ".hs"
- ipath = oDir </> "interface" </> moduleNameToPath mname ++ ".xml"
-- logMessage $ "Writing: " ++ moduleNameToName mname
liftIO $ safeWriteFile path modu'
- liftIO $ safeWriteFile ipath interf
+ writeModuleInterface rmodule
writeModuleListing :: FilePath -> [RawModule] -> RawGenIO ()
writeModuleListing fp mods = do
View
@@ -25,7 +25,7 @@ module Main.Options (
enumextFile, glFile, tmFile,
freuseFile, ereuseFile,
stripNames, mkExtensionGroups,
- outputDir,
+ outputDir, interfaceDir,
-- * Retrieving the options
getOptions,
) where
@@ -173,4 +173,7 @@ mkExtensionGroups = rgEGrouping
outputDir :: RawGenOptions -> FilePath
outputDir = rgOutputDir
+interfaceDir :: RawGenOptions -> FilePath
+interfaceDir rgo = outputDir rgo </> "interface"
+
-----------------------------------------------------------------------------
View
@@ -22,7 +22,7 @@ module Modules.Builder (
MBuilder,
-- * The generated module
- External, RawModule(..),
+ ModuleType(..), RawModule(..),
module Main.Monad,
-- * Miscellaneous functions for the builders
@@ -99,8 +99,8 @@ lgbuilder = lift . gbuilder
-----------------------------------------------------------------------------
-- | Adds a new module
-newModule :: ModuleName -> External -> [ModulePart] -> Builder ()
-newModule m e parts = Builder . tell . pure $ RawModule m e parts
+newModule :: ModuleName -> ModuleType -> [ModulePart] -> Builder ()
+newModule m t parts = Builder . tell . pure $ RawModule m t parts
-----------------------------------------------------------------------------
@@ -112,25 +112,25 @@ runMBuilder builder = runWriterT builder
addCategoryModule :: Category -> (Category -> MBuilder a) -> Builder a
addCategoryModule cat buildFunc = do
modName <- askCategoryModule cat
- isExternal <- isExposedCategory cat
+ moduType <- askCategoryModuleType cat
(a,parts) <- runMBuilder (buildFunc cat)
- newModule modName isExternal parts
+ newModule modName moduType parts
return a
-- | See `addCategoryModule`.
addCategoryModule' :: Category -> MBuilder a -> Builder a
addCategoryModule' c = addCategoryModule c . const
-- | Adds a module with a specific name.
-addModule :: ModuleName -> External -> (ModuleName -> MBuilder a) -> Builder a
-addModule modName isExternal buildFunc = do
+addModule :: ModuleName -> ModuleType -> (ModuleName -> MBuilder a) -> Builder a
+addModule modName modType buildFunc = do
(a,parts) <- runMBuilder (buildFunc modName)
- newModule modName isExternal parts
+ newModule modName modType parts
return a
-- | See `addModule`.
-addModule' :: ModuleName -> External -> MBuilder a -> Builder a
-addModule' modulName isExternal = addModule modulName isExternal . const
+addModule' :: ModuleName -> ModuleType -> MBuilder a -> Builder a
+addModule' modulName modulType = addModule modulName modulType . const
-----------------------------------------------------------------------------
@@ -37,14 +37,15 @@ addOldCoreProfile :: Int -> Int -> Builder ()
addOldCoreProfile ma mi =
let modName = ModuleName $ "Graphics.Rendering.OpenGL.Raw.Core" ++ show ma ++ show mi
in do cp <- askProfileModule ma mi False
- addModule' modName True $ tellReExportModule cp
+ addModule' modName Compatibility $ tellReExportModule cp
addARBCompatibility :: Builder ()
addARBCompatibility = do
let modFilter (Version _ _ True) = True
modFilter _ = False
modName = ModuleName "Graphics.Rendering.OpenGL.Raw.ARB.Compatibility"
- addModule' modName True $ (lift . asksCategories $ filter modFilter) >>= mkGroupModule
+ addModule' modName Compatibility $
+ (lift . asksCategories $ filter modFilter) >>= mkGroupModule
-----------------------------------------------------------------------------
View
@@ -57,9 +57,9 @@ addCoreProfiles = do
-- reexports all functions and enumeration values that are part of the
-- specification of OpenGL.
addCoreProfile
- :: Int -- ^ Major version
- -> Int -- ^ Minor version
- -> Bool -- ^ Compatibility Profile?
+ :: Major -- ^ Major version
+ -> Minor -- ^ Minor version
+ -> Deprecated -- ^ Compatibility Profile?
-> Builder ()
addCoreProfile ma mi comp = do
let catFilter (Version ma' mi' comp') =
@@ -68,7 +68,7 @@ addCoreProfile ma mi comp = do
catFilter _ = False
cats <- asksCategories (filter catFilter)
mn <- askProfileModule ma mi comp
- addModule' mn True $ do
+ addModule' mn (CoreInterface ma mi comp) $ do
mkGroupModule cats
-- let the core modules also expose the types
askTypesModule >>= tellReExportModule
@@ -97,6 +97,6 @@ addVendorModule e = do
catFilter _ = False
mn <- askVendorModule e
cats <- asksCategories (filter catFilter)
- addModule' mn True $ mkGroupModule cats
+ addModule' mn (VendorGroup e) $ mkGroupModule cats
-----------------------------------------------------------------------------
View
@@ -30,7 +30,7 @@ module Modules.ModuleNames (
askCategoryPImport,
-- * Ask-ers for other (spec related) information
- isExposedCategory,
+ askCategoryModuleType,
askCorePath,
) where
@@ -114,11 +114,14 @@ categoryModule (Name n) = throwRawError
$ "categoryModule: Category with only a name "
++ upperFirst (show n)
--- | query whether or not the module of a certain category is an exposed
--- module.
-isExposedCategory :: RawGenMonad m => Category -> m Bool
---isExposedCategory (Version _ _ _) = return False
-isExposedCategory _ = return True
+-- | Query what the module type of a given module is.
+askCategoryModuleType :: RawGenMonad m => Category -> m ModuleType
+askCategoryModuleType (Version _ _ _)
+ = return Internal
+askCategoryModuleType (Extension e n d)
+ = return $ ExtensionMod e n d
+askCategoryModuleType (Name _)
+ = throwRawError "askCategoryModuleType: Name category encountered"
-- | Asks the 'ModuleName' of a specific core profile
askProfileModule
View
@@ -66,7 +66,7 @@ addLatestProfileToRaw = do
Version ma mi _ <- asksCategories $ minimumBy (compare `on` catRanking)
latestProf <- askProfileModule ma mi False
bm <- askBaseModule
- addModule' bm True $ tellReExportModule latestProf
+ addModule' bm TopLevelGroup $ tellReExportModule latestProf
where
catRanking (Version ma mi False) = (-ma, -mi)
catRanking _ = (1, 1)
View
@@ -13,7 +13,8 @@
-----------------------------------------------------------------------------
module Modules.Types (
- RawModule(..), External,
+ RawModule(..), ModuleType(..),
+ isExternal,
ModulePart(..), Imported, GLName,
ValueType(..), FType(..),
@@ -27,18 +28,19 @@ import Language.OpenGLRaw.Base
-----------------------------------------------------------------------------
--- | Type indicating if a module is exposed to the outside world or
--- purely for internal use
-type External = Bool
-
-- | A generated module
data RawModule
= RawModule
{ rawModuleName :: ModuleName
- , externalRawModule :: External
+ , rawModuleType :: ModuleType
, rawModuleParts :: [ModulePart]
} deriving (Show)
+isExternal :: RawModule -> Bool
+isExternal rm = case rawModuleType rm of
+ Internal -> False
+ _ -> True
+
-----------------------------------------------------------------------------
-- | The parts in a module for OpenGLRaw.

0 comments on commit 2f6aa76

Please sign in to comment.