Permalink
Browse files

Adds warnings to the generated files.

A warning message can be inserted between the pragmas and the module,
which is used to warn against editing. The default is not to add any
text, but this has been overriden in testrun.sh
Simple haskell warnings and deprecation texts can be added, this is
used in the compatibility modules, the default is on. (Fixes #5)
  • Loading branch information...
1 parent 853023a commit 2d41d18a92e844da8d8eafdaabd3ceb422a78a09 @Laar committed Mar 31, 2013
View
@@ -32,6 +32,7 @@ executable OpenGLRawgen
Modules.Raw
Modules.Types
Code.ModuleCode
+ Code.PostProcessing
build-depends:
CodeGenerating >=0.1.0 && <0.3.0,
base >=4,
View
@@ -0,0 +1,6 @@
+-----------------------------------------
+-- GENERATED MODULE DO NOT EDIT --
+-----------------------------------------
+-- Any changes made to this module are --
+-- discarded when generating the files --
+-----------------------------------------
View
Binary file not shown.
View
@@ -14,7 +14,7 @@
-----------------------------------------------------------------------------
module Code.ModuleCode (
ModulePart(..), Imported,
- toModule, replaceCallConv
+ toModule
) where
-----------------------------------------------------------------------------
@@ -44,6 +44,7 @@ toModule rmodule = do
fimports <- when' (any definesFunc parts) funcImports
eimports <- when' (any definesEnum parts) enumImports
let name = rawModuleName rmodule
+ warning = rawModuleWarning rmodule
exps = map toExport parts
-- The imports that are needed when functions/enums are defined
-- overlap. The current solution probably needs improving. Untill that
@@ -52,7 +53,7 @@ toModule rmodule = do
prags = if any definesFunc parts then funcPrags else []
++ if any definesEnum parts then enumPrags else []
decls <- concat <$> traverse toDecls parts
- return $ Module noSrcLoc name prags Nothing (Just exps) imports decls
+ return $ Module noSrcLoc name prags warning (Just exps) imports decls
where
when' p m = if p then m else return []
@@ -199,17 +200,5 @@ funcTemplate name ty glname category = flip fmap askExtensionModule $ \emod ->
callConv :: CallConv
callConv = StdCall
--- | Replace every occurence of a certain calling convention by the given
--- string.
-replaceCallConv
- :: String -- The replacing calling convention
- -> String -- The source of the module
- -> String
-replaceCallConv r = go
- where
- go [] = []
- go ('s':'t':'d':'c':'a':'l':'l':xs) = r ++ go xs
- go (x :xs) = x : go xs
-
-----------------------------------------------------------------------------
View
@@ -0,0 +1,53 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Code.PostProcessing
+-- Copyright : (c) 2013 Lars Corbijn
+-- License : BSD-style (see the file /LICENSE)
+--
+-- Maintainer :
+-- Stability :
+-- Portability :
+--
+-- | Post processing of generated sources.
+--
+-----------------------------------------------------------------------------
+module Code.PostProcessing (
+ postProcessModule
+) where
+
+-----------------------------------------------------------------------------
+
+import Main.Monad
+import Main.Options
+
+-----------------------------------------------------------------------------
+
+postProcessModule :: String -> RawGen String
+postProcessModule = addModuleHeader . replaceCallConv "CALLCONV"
+
+-----------------------------------------------------------------------------
+
+-- | Replace every occurence of a certain calling convention by the given
+-- string.
+replaceCallConv
+ :: String -- The replacing calling convention
+ -> String -- The source of the module
+ -> String
+replaceCallConv r = go
+ where
+ go [] = []
+ go ('s':'t':'d':'c':'a':'l':'l':xs) = r ++ go xs
+ go (x :xs) = x : go xs
+
+-- | Adds a header to all modules.
+addModuleHeader :: String -> RawGen String
+addModuleHeader src = do
+ hdr <- asksOptions moduleHeader
+ return $ maybe src addHeader hdr
+ where
+ addHeader hdr = go src
+ where go [] = hdr
+ go ('m':'o':'d':'u':'l':'e':' ':xs) = hdr ++ "module " ++ xs
+ go (x :xs) = x : go xs
+
+-----------------------------------------------------------------------------
View
@@ -31,6 +31,7 @@ import Code.Generating.Utils
import Modules.Raw
import Modules.Types
import Code.ModuleCode
+import Code.PostProcessing
import Main.Monad
import Main.Options
@@ -106,7 +107,8 @@ outputModule rmodule = do
let mname = rawModuleName rmodule
modu <- toModule rmodule
oDir <- asksOptions outputDir
- let modu' = replaceCallConv "CALLCONV" $ prettyPrint modu
+ modu' <- liftRawGen $ postProcessModule $ prettyPrint modu
+ let -- modu' = replaceCallConv "CALLCONV" $ prettyPrint modu
path = oDir </> moduleNameToPath mname ++ ".hs"
liftIO $ safeWriteFile path modu'
writeModuleInterface rmodule
View
@@ -25,6 +25,7 @@ module Main.Options (
enumextFile, glFile, tmFile,
freuseFile, ereuseFile,
stripNames, mkExtensionGroups,
+ moduleHeader, moduleWarnings,
outputDir, interfaceDir,
-- * Retrieving the options
getOptions,
@@ -89,6 +90,14 @@ options =
(NoArg $ \r -> return r{rgEGrouping = False}) "Disables the generation of Extension group modules"
, Option ['o'] ["output"]
(ReqArg (\d r -> return r{rgOutputDir = d}) "DIR") "The output directory"
+ , Option ['w'] ["warning"]
+ (ReqArg (\w r -> return r{rgModHeader = Just w}) "MSG") "Module header message"
+ , Option [] ["warning-file"]
+ (ReqArg (\wf r -> do
+ fc <- readFile wf -- TODO: add check that it is present?
+ return $ r{rgModHeader = Just fc}) "FILE") "File with the module header message"
+ , Option [] ["no-module-warnings"]
+ (NoArg $ \r -> return r{rgModWarns = False}) "Disables haskell module warnings"
]
where
flag :: RawGenFlag -> ArgDescr (RawGenOptions -> IO RawGenOptions)
@@ -123,6 +132,8 @@ data RawGenOptions
, rgFilesDir :: Maybe FilePath -- ^ The location to search for files
, rgStripName :: Bool -- ^ Strip the names of extensions
, rgEGrouping :: Bool -- ^ Adds all the grouping modules for extensions
+ , rgModHeader :: Maybe String -- ^ An optional header above the module
+ , rgModWarns :: Bool -- ^ Warning and deprecation texts on modules
, rgOutputDir :: FilePath
}
@@ -139,6 +150,8 @@ defaultOptions
, rgFilesDir = Nothing
, rgStripName = False
, rgEGrouping = True
+ , rgModHeader = Nothing
+ , rgModWarns = True
, rgOutputDir = ""
}
@@ -170,6 +183,12 @@ stripNames = rgStripName
mkExtensionGroups :: RawGenOptions -> Bool
mkExtensionGroups = rgEGrouping
+moduleHeader :: RawGenOptions -> Maybe String
+moduleHeader = rgModHeader
+
+moduleWarnings :: RawGenOptions -> Bool
+moduleWarnings = rgModWarns
+
outputDir :: RawGenOptions -> FilePath
outputDir = rgOutputDir
View
@@ -28,6 +28,7 @@ module Modules.Builder (
-- * Miscellaneous functions for the builders
addCategoryModule, addCategoryModule',
addModule, addModule',
+ addModuleWithWarning,
runBuilder,
-- * ModuleBuilding related
@@ -59,6 +60,7 @@ import Control.Monad.Writer
import Language.Haskell.Exts.Syntax
import Spec
+import Main.Options
import Main.Monad
import Modules.ModuleNames
@@ -99,8 +101,8 @@ lgbuilder = lift . gbuilder
-----------------------------------------------------------------------------
-- | Adds a new module
-newModule :: ModuleName -> ModuleType -> [ModulePart] -> Builder ()
-newModule m t parts = Builder . tell . pure $ RawModule m t parts
+newModule :: ModuleName -> ModuleType -> Maybe WarningText -> [ModulePart] -> Builder ()
+newModule m t wt parts = Builder . tell . pure $ RawModule m t wt parts
-----------------------------------------------------------------------------
@@ -114,7 +116,7 @@ addCategoryModule cat buildFunc = do
modName <- askCategoryModule cat
moduType <- askCategoryModuleType cat
(a,parts) <- runMBuilder (buildFunc cat)
- newModule modName moduType parts
+ newModule modName moduType Nothing parts
return a
-- | See `addCategoryModule`.
@@ -125,13 +127,22 @@ addCategoryModule' c = addCategoryModule c . const
addModule :: ModuleName -> ModuleType -> (ModuleName -> MBuilder a) -> Builder a
addModule modName modType buildFunc = do
(a,parts) <- runMBuilder (buildFunc modName)
- newModule modName modType parts
+ newModule modName modType Nothing parts
return a
-- | See `addModule`.
addModule' :: ModuleName -> ModuleType -> MBuilder a -> Builder a
addModule' modulName modulType = addModule modulName modulType . const
+addModuleWithWarning :: ModuleName -> ModuleType -> WarningText
+ -> MBuilder a -> Builder a
+addModuleWithWarning modName modType modWarning buildFunc = do
+ (a, parts) <- runMBuilder buildFunc
+ w <- asksOptions moduleWarnings
+ let warning = if w then Just modWarning else Nothing
+ newModule modName modType warning parts
+ return a
+
-----------------------------------------------------------------------------
-- | Lifted version of `unwrapName` supplying the needed options.
@@ -37,22 +37,27 @@ addCompatibilityModules = do
addOldCoreProfile :: Int -> Int -> Builder ()
addOldCoreProfile ma mi =
let modName = ModuleName $ "Graphics.Rendering.OpenGL.Raw.Core" ++ show ma ++ show mi
+ warning = DeprText "\"The core modules are moved to Graphics.Rendering.OpenGL.Raw.Core.CoreXY\""
in do cp <- askProfileModule ma mi False
- addModule' modName Compatibility $ tellReExportModule cp
+ addModuleWithWarning modName
+ Compatibility warning $ tellReExportModule cp
addOldCoreTypes :: Builder ()
addOldCoreTypes = do
let modName = ModuleName "Graphics.Rendering.OpenGL.Raw.Core31.Types"
+ warning = DeprText "\"The OpenGL types are moved to Graphics.Rendering.OpenGL.Raw.Types .\""
typesModule <- askTypesModule
- addModule' modName Compatibility $ tellReExportModule typesModule
+ addModuleWithWarning modName
+ Compatibility warning $ tellReExportModule typesModule
addARBCompatibility :: Builder ()
addARBCompatibility = do
let modFilter (Version _ _ True) = True
modFilter _ = False
modName = ModuleName "Graphics.Rendering.OpenGL.Raw.ARB.Compatibility"
- addModule' modName Compatibility $
+ warning = DeprText "\"The ARB.Compatibility is combined with the profiles.\""
+ addModuleWithWarning modName Compatibility warning $
(lift . asksCategories $ filter modFilter) >>= mkGroupModule
-----------------------------------------------------------------------------
View
@@ -33,6 +33,7 @@ data RawModule
= RawModule
{ rawModuleName :: ModuleName
, rawModuleType :: ModuleType
+ , rawModuleWarning :: Maybe WarningText
, rawModuleParts :: [ModulePart]
} deriving (Show)
View
@@ -18,8 +18,8 @@ mkdir "$TESTDIR"
echo "---------------------------"
echo "-- Generating new output --"
echo "---------------------------"
-time ./OpenGLRawgen --no-vendorf=input/novendor -o "$TESTDIR/normal/" -c --groups -d input +RTS -sstderr &&
-./OpenGLRawgen --no-vendorf=input/novendor -o "$TESTDIR/striped/" -c -s -d input
+time ./OpenGLRawgen --no-vendorf=input/novendor -o "$TESTDIR/normal/" -c --groups -d input --warning-file=input/warningfile +RTS -sstderr &&
+./OpenGLRawgen --no-vendorf=input/novendor -o "$TESTDIR/striped/" -c -s -d input --warning-file=input/warningfile
if [[ $? == 0 ]] ;
then

0 comments on commit 2d41d18

Please sign in to comment.