diff --git a/backends/AnalyseAsm.hs b/backends/AnalyseAsm.hs index bf26924..e81a3d5 100644 --- a/backends/AnalyseAsm.hs +++ b/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 diff --git a/checks/Check.hs b/checks/Check.hs index 9f07f1a..97208e7 100644 --- a/checks/Check.hs +++ b/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 diff --git a/checks/UsageCheckTest.hs b/checks/UsageCheckTest.hs index cda881e..9b0d568 100644 --- a/checks/UsageCheckTest.hs +++ b/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 diff --git a/common/Errors.hs b/common/Errors.hs index 6a85de1..3a0e735 100644 --- a/common/Errors.hs +++ b/common/Errors.hs @@ -17,9 +17,9 @@ with this program. If not, see . -} -- | 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. diff --git a/data/CompState.hs b/data/CompState.hs index 6dac17a..243002e 100644 --- a/data/CompState.hs +++ b/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 diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index f297308..226d4c4 100644 --- a/frontends/ParseOccam.hs +++ b/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 diff --git a/frontends/PreprocessOccam.hs b/frontends/PreprocessOccam.hs index af378cd..fbea195 100644 --- a/frontends/PreprocessOccam.hs +++ b/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