module Util.Exception (
Exception,
LibCSPMException(..),
throwException,
MonadIOException(..),
panic, throwSourceError,
mkErrorMessage, mkWarningMessage,
ErrorMessage, ErrorMessages,
)
where
import Control.Exception
import Control.Monad.State
import Data.Typeable
import Data.List
import Prelude hiding (catch)
import Util.Annotated
import Util.PrettyPrint
type ErrorMessages = [ErrorMessage]
data ErrorMessage =
ErrorMessage {
location :: SrcSpan,
message :: Doc
}
| WarningMessage {
location :: SrcSpan,
message :: Doc
}
mkErrorMessage :: SrcSpan -> Doc -> ErrorMessage
mkErrorMessage l d = ErrorMessage l d
mkWarningMessage :: SrcSpan -> Doc -> ErrorMessage
mkWarningMessage l d = WarningMessage l (text "Warning" <> colon <+> d)
instance Eq ErrorMessage where
m1 == m2 = location m1 == location m2
instance Ord ErrorMessage where
compare m1 m2 = compare (location m1) (location m2)
instance PrettyPrintable ErrorMessages where
prettyPrint ms = vcat . punctuate (text "\n") . map prettyPrint . sort $ ms
instance PrettyPrintable ErrorMessage where
prettyPrint m =
hang (prettyPrint (location m) <> colon) 4 (message m)
instance Show ErrorMessage where
show m = show (prettyPrint m)
data LibCSPMException =
Panic String
| SourceError ErrorMessages
| UserError
deriving Typeable
instance Show LibCSPMException where
show (Panic str) = "Internal inconsitancy error: "++str
show (SourceError ms) = show (prettyPrint ms)
show (UserError) = "An unknown error occured."
instance Exception LibCSPMException
throwSourceError :: ErrorMessages -> a
throwSourceError = throwException . SourceError
panic :: String -> a
panic = throwException . Panic
throwException :: Exception e => e -> a
throwException = throw
class Monad m => MonadIOException m where
tryM :: (MonadIOException m) => m a -> m (Either LibCSPMException a)
instance MonadIOException IO where
tryM prog = do
r <- try prog
case r of
Left (e@(Panic s)) -> throwException e
_ -> return r
instance MonadIOException m => MonadIOException (StateT s m) where
tryM prog =
StateT $ \st -> do
x <- tryM (runStateT prog st)
case x of
Right (a, s) -> return $ (Right a, s)
Left e -> return $ (Left e, st)