boltzmann-brain-1.3.1.3: Data/Boltzmann/System/Errors.hs
{-|
Module : Data.Boltzmann.System.Errors
Description : Various error handling utilities.
Copyright : (c) Maciej Bendkowski, 2017
License : BSD3
Maintainer : maciej.bendkowski@tcs.uj.edu.pl
Stability : experimental
Common error utilities for combinatorial systems.
-}
module Data.Boltzmann.System.Errors
( SystemError
, ErrorMonad
, errors
) where
import Control.Monad.Except
import Data.Map (Map)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.MultiSet (MultiSet)
import qualified Data.MultiSet as MultiSet
import Data.Char (isUpper)
import Text.Read (readMaybe)
import Data.Boltzmann.System
import Data.Boltzmann.System.Jacobian
-- | Semantic system errors referring to invalid
-- input data, for instance ill-founded systems.
data SystemError = Inconsistent String -- Type name
String -- Constructor name
String -- Argument name
| InvalidCons String -- Type name
String -- Constructor name
| ClashCons [String] -- Clashing constructors
| Illfounded -- Ill-founded system
| Infinite -- Infinite structures
| Frequencies [String] -- Incorrect frequencies
| InvalidPrecision -- Invalid precision
| InvalidMaxIter -- Invalid maxiter
| InvalidModule -- Invalid module
| UnsupportedSystemType String -- Invalid system type
instance Show SystemError where
show (Inconsistent t con arg) = "[Error] Invalid argument type '"
++ arg ++ "' in constructor " ++ con ++ " of type " ++ t ++ "."
show (InvalidCons t con) = "[Error] Invalid constructor '" ++ con
++ "' in type " ++ t ++ ": '" ++ con ++ "' names a declared type."
show (ClashCons cons) = "[Error] Clashing constructor names: "
++ foldl1 (\c c' -> "'" ++ c ++ "', " ++ "'" ++ c' ++ "'") cons
++ "."
show Illfounded = "[Error] Ill-founded system."
show Infinite = "[Error] System defines no finite structures."
show (Frequencies ts) = "[Error] Incorrect frequencies (expected real in [0.0,1.0]): "
++ foldl1 (\c c' -> "'" ++ c ++ "', " ++ "'" ++ c' ++ "'") ts
++ "."
show InvalidPrecision = "[Error] Invalid precision annotation. "
++ "Expected a positive floating point number."
show InvalidMaxIter = "[Error] Invalid maxiter annotation. "
++ "Expected a positive integer."
show InvalidModule = "[Error] Invalid module annotation. "
++ "Expected a name starting with an upper case letter."
show (UnsupportedSystemType s) = "[Error] Unsupported system type. " ++ s
-- | Monadic error handling wrapper.
type ErrorMonad = Either SystemError
-- | Checks whether the given input system is correct, yielding its type.
-- Otherwise, returns an appropriate SystemError.
errors :: Bool -> System Int -> ErrorMonad SystemType
errors useForce sys = do
void $ consistent sys
void $ validCons sys
void $ clashCons sys
void $ infinite sys
void $ incorrectFrequencies sys
void $ invalidAnnotations sys
unless useForce $ illfounded sys
invalidSystemType sys
invalidSystemType :: System a -> ErrorMonad SystemType
invalidSystemType sys =
case systemType sys of
(Unsupported s) -> throwError (UnsupportedSystemType s) `catchError` Left
sysT -> return sysT
infinite :: System a -> ErrorMonad ()
infinite sys = unless (hasAtoms sys || not (null $ seqTypes sys)) $ throwError Infinite `catchError` Left
consistent :: System a -> ErrorMonad ()
consistent sys = mapM_ consistentType (M.toList $ defs sys) `catchError` Left
where ts = types sys
consistentType (t,cons) = mapM_ (consistentCons t) cons
consistentCons t con = mapM_ (consistentArg t con) $ args con
consistentArg :: String -> Cons a -> Arg -> ErrorMonad ()
consistentArg t con (List s)
| s `S.member` ts = return ()
| otherwise = throwError $ Inconsistent t (func con) s
consistentArg t con (Type s)
| s `S.member` ts = return ()
| otherwise = throwError $ Inconsistent t (func con) s
validCons :: System a -> ErrorMonad ()
validCons sys = mapM_ validType (M.toList $ defs sys) `catchError` Left
where ts = types sys
validType (t,cons) = mapM_ (validCon t) cons
validCon :: String -> Cons a -> ErrorMonad ()
validCon t con
| null (args con) && func con `S.member` ts =
throwError $ InvalidCons t (func con)
| otherwise = return ()
consNames :: System a -> MultiSet String
consNames sys = MultiSet.unions (map insT $ M.elems (defs sys))
where insT = MultiSet.fromList . map func
duplicates :: System a -> [String]
duplicates sys = map fst $ filter gather $ MultiSet.toOccurList ms
where gather (_,n) = n /= 1
ms = consNames sys
clashCons :: System a -> ErrorMonad ()
clashCons sys = let cs = duplicates sys in
unless (null cs) $ throwError (ClashCons cs) `catchError` Left
illfounded :: System Int -> ErrorMonad ()
illfounded sys = unless (wellFounded sys) $ throwError Illfounded `catchError` Left
incorrectFrequencies :: System Int -> ErrorMonad ()
incorrectFrequencies sys = unless (null fs) $ throwError (Frequencies fs) `catchError` Left
where fs = incorrectFrequencies' sys
incorrectFrequencies' :: System Int -> [String]
incorrectFrequencies' sys = concatMap incF $ M.elems (defs sys)
where incF cons = map func $ filter incF' cons
incF' cons = case frequency cons of
Nothing -> False
Just f -> 0.0 > f || 1.0 < f
-- | General, compiler-independent admissible annotations.
invalidAnnotations :: System Int -> ErrorMonad ()
invalidAnnotations sys = do
let ann = annotations sys
void $ precisionAnnotation ann
void $ maxiterAnnotation ann
moduleAnnotation ann
precisionAnnotation :: Map String String -> ErrorMonad ()
precisionAnnotation ann =
case "precision" `M.lookup` ann of
Nothing -> return ()
Just x -> case readMaybe x :: Maybe Double of
Nothing -> throwError InvalidPrecision
Just x' -> unless (x' > 0) $ throwError InvalidPrecision `catchError` Left
maxiterAnnotation :: Map String String -> ErrorMonad ()
maxiterAnnotation ann =
case "maxiter" `M.lookup` ann of
Nothing -> return ()
Just x -> case readMaybe x :: Maybe Int of
Nothing -> throwError InvalidMaxIter
Just x' -> unless (x' > 0) $ throwError InvalidMaxIter `catchError` Left
moduleAnnotation :: Map String String -> ErrorMonad ()
moduleAnnotation ann =
case "module" `M.lookup` ann of
Nothing -> return ()
Just x -> unless (isUpper $ head x) $ throwError InvalidModule `catchError` Left