{-# LANGUAGE ExistentialQuantification #-}
module Data.Boltzmann.System.Warnings
( warnings
) where
import Control.Monad (unless)
import Data.Maybe (mapMaybe)
import System.Exit
import qualified Data.Map.Strict as M
import Data.Boltzmann.System
import Data.Boltzmann.Internal.Utils
import qualified Data.Boltzmann.Internal.Logging as L
class SystemWarn a where
report :: a -> String
data WarningExt = forall a. (SystemWarn a) => WarningExt a
data ConsWeightWarn =
ConsWeightWarn { consWeightType :: String
, consWeightCons :: String
}
consWeightWarn :: (Eq a, Num a) => System a -> [WarningExt]
consWeightWarn sys =
concatMap nullType (M.toList $ defs sys)
where
nullCons typ cons
| null (args cons) && weight cons == 0 =
Just $ WarningExt ConsWeightWarn { consWeightType = typ
, consWeightCons = func cons
}
| otherwise = Nothing
nullType (typ, cons) = mapMaybe (nullCons typ) cons
instance SystemWarn ConsWeightWarn where
report warn = "Found a constructor " ++ cons'
++ " in type " ++ typ' ++ " of weight 0."
where
cons' = quote $ consWeightCons warn
typ' = quote $ consWeightType warn
reportWarning :: WarningExt -> IO ()
reportWarning (WarningExt warn) = L.warn (report warn)
checkWarns :: Bool -> [WarningExt] -> IO ()
checkWarns werror warns = do
mapM_ reportWarning warns
unless (null warns || not werror)
(exitWith $ ExitFailure 1)
warningList :: System Int -> [WarningExt]
warningList = consWeightWarn
warnings :: Bool -> System Int -> IO ()
warnings werror sys = checkWarns werror (warningList sys)