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)

OpenGLRawgen.cabal

@@ -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,

input/warningfile

@@ -0,0 +1,6 @@
+-----------------------------------------
+--    GENERATED MODULE DO NOT EDIT     --
+-----------------------------------------
+-- Any changes made to this module are --
+-- discarded when generating the files --
+-----------------------------------------

src/Code/ModuleCode.hs

@@ -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
-
 -----------------------------------------------------------------------------
 

src/Code/PostProcessing.hs

@@ -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
+
+-----------------------------------------------------------------------------

src/Main.hs

@@ -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

src/Main/Options.hs

@@ -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
 

src/Modules/Builder.hs

@@ -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.

src/Modules/Compatibility.hs

@@ -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
 
 -----------------------------------------------------------------------------

src/Modules/Types.hs

@@ -33,6 +33,7 @@ data RawModule
     = RawModule
     { rawModuleName     :: ModuleName
     , rawModuleType     :: ModuleType
+    , rawModuleWarning  :: Maybe WarningText
     , rawModuleParts    :: [ModulePart]
     } deriving (Show)
 

testrun.sh

@@ -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