Permalink
Browse files

Merge branch 'interface2' into develop

Conflicts:
	.travis.yml
  • Loading branch information...
2 parents e53797a + 6dccf87 commit 38c32ce5e4ee7cd48fa02a60b356df2fd5b6d9e0 @Laar committed Mar 27, 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
@@ -6,5 +6,5 @@ then
fi
CABAL="$1"
git submodule update --init --recursive
-$CABAL install opengl-api/ CodeGenerating/ OpenGLRawgenBase/OpenGLRawgenBase/
+$CABAL install opengl-api/ CodeGenerating/ OpenGLRawgenBase/OpenGLRawgenBase/ OpenGLRawgenBase/OpenGLRawInterface/
$CABAL install --only-dependencies
View
Binary file not shown.
View
@@ -1,83 +1,108 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Interface.Module
+-- Copyright : (c) 2013 Lars Corbijn
+-- License : BSD-style (see the file /LICENSE)
+--
+-- Maintainer :
+-- Stability :
+-- Portability :
+--
+-- | The interface writing part of the generator.
+--
+-----------------------------------------------------------------------------
+
module Interface.Module (
- moduleToRenderedInterface,
- moduleToInterface
+ moduleToInterface, writeModuleInterface,
+ writePackageInterface,
+ verifyInterface,
) where
-import Language.Haskell.Exts.Syntax hiding (QName)
-import Code.Generating.Utils
-import Data.String
-import Text.XML.Light
+-----------------------------------------------------------------------------
-import Modules.Types
-moduleToRenderedInterface :: RawModule -> String
-moduleToRenderedInterface = ppTopElement . moduleToInterface
+import Control.Monad
+import Language.Haskell.Exts.Syntax
+import Data.List
+import qualified Data.Foldable as F
+import qualified Data.Set as S
-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
+import Language.OpenGLRaw.Interface.Serialize
+import Language.OpenGLRaw.Interface.Types
-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
+import Main.Monad
+import Main.Options
+import Modules.Types
--- To make constructing xml easier
-instance IsString QName where
- fromString = unqual
+-----------------------------------------------------------------------------
-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" ()
+-- | Writes the package/index interface file.
+writePackageInterface :: [RawModule] -> RawGenIO ()
+writePackageInterface modus = do
+ let inter = OpenGLRawI . S.fromList $ map rawModuleName modus
+ path <- asksOptions interfaceDir
+ liftIO $ writePackage path inter
-enumElem :: Name -> GLName -> ValueType -> Element
-enumElem name glname vt =
- node "enum"
- [ Attr "glname" glname
- , Attr "name" $ unname name
- , Attr "type" valType
- ]
+-- | Writes the interface file for a single `RawModule`.
+writeModuleInterface :: RawModule -> RawGenIO ()
+writeModuleInterface modu = do
+ path <- asksOptions interfaceDir
+ liftIO . writeModule path $ moduleToInterface modu
+
+-- | Converts a single module to its interface representation.
+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
+
+-- | Adds a `ModulePart` to the interface of a module.
+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"
+ 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
-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]
+-- | Performs some simple checks on the interface files.
+verifyInterface :: [RawModule] -> RawGenIO ()
+verifyInterface rmods = do
+ let rmodNames = S.fromList $ map rawModuleName rmods
+ logMessage "Verifying interface files"
+ iDir <- asksOptions interfaceDir
+ mpack <- liftEitherPrepend "Package interface verifying failed"
+ =<< liftIO (readPackage iDir)
+ let imodNames = rawMods mpack
+ unless (imodNames == rmodNames) . throwRawError . unlines $
+ [ "The modules in the interface and the generated modules are not the same!"
+ , "Missing interfaces:"
+ ] ++ (map unmodName $ S.toList (rmodNames S.\\ imodNames)) ++
+ [ "Excess interfaces:"
+ ] ++ (map unmodName $ S.toList (imodNames S.\\ rmodNames))
+ F.mapM_ verifyModule $ rawMods mpack
+ where
+ unmodName (ModuleName mn) = mn
+-- | Verification of a single module from the interface.
+verifyModule :: ModuleName -> RawGenIO ()
+verifyModule mn = do
+ iDir <- asksOptions interfaceDir
+ _ <- liftEitherPrepend errMsg =<< liftIO (readModule iDir mn)
+ return ()
+ where
+ errMsg = "Module interface parsing failed for: " ++ mName
+ (ModuleName mName) = mn
+-----------------------------------------------------------------------------
View
@@ -62,6 +62,7 @@ rmain = do
let lMap'' = cleanupSpec opts lMap'
modules <- liftRawGen $ makeRaw (lMap'', vMap)
outputModules modules
+ verifyInterface modules
-- | Parse and process the reuse files. It generates no warning if there is
-- no reuse file to parse
@@ -92,24 +93,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)
Oops, something went wrong.

0 comments on commit 38c32ce

Please sign in to comment.