Added a value to indicate what type a warning is (to support future configurability) and streamlined the warning functions

backends/AnalyseAsm.hs

@@ -179,7 +179,7 @@ addCalls
 
     systemFunc :: String -> AAM Int
     systemFunc func
-        =  do lift $ addPlainWarning $ "Unknown function " ++ func ++ "; allocating " ++ show unknownSize ++ " bytes stack"
+        =  do lift $ warnPlainP WarnInternal $ "Unknown function " ++ func ++ "; allocating " ++ show unknownSize ++ " bytes stack"
               return unknownSize
 
     userFunc :: FunctionInfo -> AAM Int

checks/Check.hs

@@ -236,7 +236,7 @@ checkInitVar m graph startNode
         -- The read-from set should be a subset of the written-to set:
         if filterPlain' v `isSubsetOf` filterPlain' vs then return () else 
           do vars <- showCodeExSet $ filterPlain' v `difference` filterPlain' vs
-             addWarning (getMeta n) $ "Variable(s) read from are not written to before-hand: " ++ vars
+             warnP (getMeta n) WarnUninitialisedVariable $ "Variable(s) read from are not written to before-hand: " ++ vars
 
 checkParAssignUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t) => t -> m ()
 checkParAssignUsage = mapM_ checkParAssign . listify isParAssign

checks/UsageCheckTest.hs

@@ -129,7 +129,7 @@ type TestM = ReaderT CompState (Either String)
 instance Die TestM where
   dieReport (_,s) = throwError s
 instance Warn TestM where
-  warnReport (_,s) = throwError s
+  warnReport (_,_,s) = throwError s
 
 buildTestFlowGraph :: [(Int, [Var], [Var])] -> [(Int, Int, EdgeLabel)] -> Int -> Int -> String -> FlowGraph TestM UsageLabel
 buildTestFlowGraph ns es start end v

common/Errors.hs

@@ -17,9 +17,9 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | Error handling and reporting.
-module Errors (addPlainWarning, addWarning, checkJust, Die(..),
+module Errors (checkJust, Die(..),
   dieInternal, dieIO, dieP, ErrorReport,
-  showWarnings, Warn(..), WarningReport, warnP) where
+  showWarnings, Warn(..), WarningReport, warnP, warnPlainP, WarningType(..), describeWarning) where
 
 import Control.Monad.Error
 import Control.Monad.Trans
@@ -42,22 +42,40 @@ class Monad m => Die m where
 dieP :: Die m => Meta -> String -> m a
 dieP m s = dieReport (Just m,s)
 
-type WarningReport = (Maybe Meta, String)
+
+data WarningType
+  = WarnInternal
+  | WarnParserOddity
+  | WarnUnknownPreprocessorDirective
+  | WarnUninitialisedVariable
+  | WarnUnusedVariable
+  deriving (Eq, Show, Ord, Read, Enum, Bounded)
+-- I intend the above warnings to be part of a command-line mechanism to enable
+-- or suppress them according to various flags.  So that you might write:
+-- -WnoWarnParserOddity
+-- For which we can do a tiny bit of parsing, and use the Read instance to help,
+-- as well as using the Enum and Bounded instances to easily discover all warnings
+
+describeWarning :: WarningType -> String
+describeWarning WarnInternal = "Internal compiler problems"
+describeWarning WarnParserOddity = "Strange things in your code that indicate possible errors"
+describeWarning WarnUnknownPreprocessorDirective = "Unrecognised preprocessor directive"
+describeWarning WarnUninitialisedVariable = "A variable that is read from before being written to"
+describeWarning WarnUnusedVariable = "A variable that is declared but never used"
+
+type WarningReport = (Maybe Meta, WarningType, String)
 
 class Monad m => Warn m where
   warnReport :: WarningReport -> m ()
 
-warnP :: Warn m => Meta -> String -> m ()
-warnP m s = warnReport (Just m,s)
-
 --{{{  warnings
 -- | Add a warning with no source position.
-addPlainWarning :: Warn m => String -> m ()
-addPlainWarning msg = warnReport (Nothing, msg)
+warnPlainP :: Warn m => WarningType -> String -> m ()
+warnPlainP t msg = warnReport (Nothing, t, msg)
 
 -- | Add a warning.
-addWarning :: Warn m => Meta -> String -> m ()
-addWarning m s = warnReport (Just m, s)
+warnP :: Warn m => Meta -> WarningType -> String -> m ()
+warnP m t s = warnReport (Just m, t, s)
 --}}}
 
 -- | Wrapper around error that gives nicer formatting, and prints out context
@@ -112,8 +130,10 @@ printError s = error $ "Error: " ++ s ++ "\n"
 showWarnings ::  MonadIO m => [WarningReport] -> m ()
 showWarnings = mapM_ printWarning
   where
-    printWarning (Just m, s) = liftIO $ hPutStrLn stderr $ show m ++ " " ++ s
-    printWarning (Nothing, s) = liftIO $ hPutStrLn stderr s
+    printWarning (Just m, t, s)
+      = liftIO $ hPutStrLn stderr $ show m ++ " " ++ show t ++ " " ++ s
+    printWarning (Nothing, t, s)
+      = liftIO $ hPutStrLn stderr (show t ++ " " ++ s)
 
 
 -- | Fail after an internal error.

data/CompState.hs

@@ -31,7 +31,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 
 import qualified AST as A
-import Errors (Die, dieP, ErrorReport, Warn, warnP)
+import Errors (Die, dieP, ErrorReport, Warn, WarningType, warnP)
 import Metadata
 import OrdAST ()
 import UnifyType
@@ -376,8 +376,8 @@ makeNonceVariable s m t am
 diePC :: (CSMR m, Die m) => Meta -> m String -> m a
 diePC m str = str >>= (dieP m)
 
-warnPC :: (CSMR m, Warn m) => Meta -> m String -> m ()
-warnPC m str = str >>= (warnP m)
+warnPC :: (CSMR m, Warn m) => Meta -> WarningType -> m String -> m ()
+warnPC m t str = str >>= (warnP m t)
 
 --dieC :: (CSM m, Die m) => m String -> m a
 --dieC str = str >>= die

frontends/ParseOccam.hs

@@ -318,7 +318,7 @@ maybeIndentedList m msg inner
            vs <- many1 inner
            outdent
            return vs
-    <|> do addWarning m msg
+    <|> do warnP m WarnParserOddity msg
            return []
 
 handleSpecs :: OccParser [NameSpec] -> OccParser a -> (Meta -> A.Specification -> a -> a) -> OccParser a

frontends/PreprocessOccam.hs

@@ -141,7 +141,7 @@ handleDirective m s x
     -- currently we support so few preprocessor directives that this is more
     -- useful.
     lookup s []
-        =  do addWarning m "Unknown preprocessor directive ignored"
+        =  do warnP m WarnUnknownPreprocessorDirective "Unknown preprocessor directive ignored"
               return return
     lookup s ((re, func):ds)
         = case matchRegex re s of