{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
module Language.C.Data.Error (
ErrorLevel(..), isHardError,
Error(..), errorPos, errorLevel, errorMsgs,
CError(..),
ErrorInfo(..),showError,showErrorInfo,mkErrorInfo,
UnsupportedFeature, unsupportedFeature, unsupportedFeature_,
UserError, userErr,
internalErr,
)
where
import Data.Typeable
import Language.C.Data.Node
import Language.C.Data.Position
data ErrorLevel = LevelWarn
| LevelError
| LevelFatal
deriving (ErrorLevel -> ErrorLevel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorLevel -> ErrorLevel -> Bool
$c/= :: ErrorLevel -> ErrorLevel -> Bool
== :: ErrorLevel -> ErrorLevel -> Bool
$c== :: ErrorLevel -> ErrorLevel -> Bool
Eq, Eq ErrorLevel
ErrorLevel -> ErrorLevel -> Bool
ErrorLevel -> ErrorLevel -> Ordering
ErrorLevel -> ErrorLevel -> ErrorLevel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ErrorLevel -> ErrorLevel -> ErrorLevel
$cmin :: ErrorLevel -> ErrorLevel -> ErrorLevel
max :: ErrorLevel -> ErrorLevel -> ErrorLevel
$cmax :: ErrorLevel -> ErrorLevel -> ErrorLevel
>= :: ErrorLevel -> ErrorLevel -> Bool
$c>= :: ErrorLevel -> ErrorLevel -> Bool
> :: ErrorLevel -> ErrorLevel -> Bool
$c> :: ErrorLevel -> ErrorLevel -> Bool
<= :: ErrorLevel -> ErrorLevel -> Bool
$c<= :: ErrorLevel -> ErrorLevel -> Bool
< :: ErrorLevel -> ErrorLevel -> Bool
$c< :: ErrorLevel -> ErrorLevel -> Bool
compare :: ErrorLevel -> ErrorLevel -> Ordering
$ccompare :: ErrorLevel -> ErrorLevel -> Ordering
Ord)
instance Show ErrorLevel where
show :: ErrorLevel -> String
show ErrorLevel
LevelWarn = String
"WARNING"
show ErrorLevel
LevelError = String
"ERROR"
show ErrorLevel
LevelFatal = String
"FATAL ERROR"
isHardError :: (Error ex) => ex -> Bool
isHardError :: forall ex. Error ex => ex -> Bool
isHardError = ( forall a. Ord a => a -> a -> Bool
> ErrorLevel
LevelWarn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorLevel
errorLevel
data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable
instance Show ErrorInfo where show :: ErrorInfo -> String
show = String -> ErrorInfo -> String
showErrorInfo String
"error"
instance Error ErrorInfo where
errorInfo :: ErrorInfo -> ErrorInfo
errorInfo = forall a. a -> a
id
changeErrorLevel :: ErrorInfo -> ErrorLevel -> ErrorInfo
changeErrorLevel (ErrorInfo ErrorLevel
_ Position
pos [String]
msgs) ErrorLevel
lvl' = ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
lvl' Position
pos [String]
msgs
mkErrorInfo :: ErrorLevel -> String -> NodeInfo -> ErrorInfo
mkErrorInfo :: ErrorLevel -> String -> NodeInfo -> ErrorInfo
mkErrorInfo ErrorLevel
lvl String
msg NodeInfo
node = ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
lvl (NodeInfo -> Position
posOfNode NodeInfo
node) (String -> [String]
lines String
msg)
data CError
= forall err. (Error err) => CError err
deriving Typeable
class (Typeable e, Show e) => Error e where
errorInfo :: e -> ErrorInfo
toError :: e -> CError
fromError :: CError -> (Maybe e)
changeErrorLevel :: e -> ErrorLevel -> e
fromError (CError err
e) = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast err
e
toError = forall err. Error err => err -> CError
CError
changeErrorLevel e
e ErrorLevel
lvl =
if forall e. Error e => e -> ErrorLevel
errorLevel e
e forall a. Eq a => a -> a -> Bool
== ErrorLevel
lvl
then e
e
else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"changeErrorLevel: not possible for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
e
instance Show CError where
show :: CError -> String
show (CError err
e) = forall a. Show a => a -> String
show err
e
instance Error CError where
errorInfo :: CError -> ErrorInfo
errorInfo (CError err
err) = forall e. Error e => e -> ErrorInfo
errorInfo err
err
toError :: CError -> CError
toError = forall a. a -> a
id
fromError :: CError -> Maybe CError
fromError = forall a. a -> Maybe a
Just
changeErrorLevel :: CError -> ErrorLevel -> CError
changeErrorLevel (CError err
e) = forall err. Error err => err -> CError
CError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel err
e
errorPos :: (Error e) => e -> Position
errorPos :: forall e. Error e => e -> Position
errorPos = ( \(ErrorInfo ErrorLevel
_ Position
pos [String]
_) -> Position
pos ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorInfo
errorInfo
errorLevel :: (Error e) => e -> ErrorLevel
errorLevel :: forall e. Error e => e -> ErrorLevel
errorLevel = ( \(ErrorInfo ErrorLevel
lvl Position
_ [String]
_) -> ErrorLevel
lvl ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorInfo
errorInfo
errorMsgs :: (Error e) => e -> [String]
errorMsgs :: forall e. Error e => e -> [String]
errorMsgs = ( \(ErrorInfo ErrorLevel
_ Position
_ [String]
msgs) -> [String]
msgs ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorInfo
errorInfo
data UnsupportedFeature = UnsupportedFeature String Position deriving Typeable
instance Error UnsupportedFeature where
errorInfo :: UnsupportedFeature -> ErrorInfo
errorInfo (UnsupportedFeature String
msg Position
pos) = ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
LevelError Position
pos (String -> [String]
lines String
msg)
instance Show UnsupportedFeature where show :: UnsupportedFeature -> String
show = forall e. Error e => String -> e -> String
showError String
"Unsupported Feature"
unsupportedFeature :: (Pos a) => String -> a -> UnsupportedFeature
unsupportedFeature :: forall a. Pos a => String -> a -> UnsupportedFeature
unsupportedFeature String
msg a
a = String -> Position -> UnsupportedFeature
UnsupportedFeature String
msg (forall a. Pos a => a -> Position
posOf a
a)
unsupportedFeature_ :: String -> UnsupportedFeature
unsupportedFeature_ :: String -> UnsupportedFeature
unsupportedFeature_ String
msg = String -> Position -> UnsupportedFeature
UnsupportedFeature String
msg Position
internalPos
newtype UserError = UserError ErrorInfo deriving Typeable
instance Error UserError where
errorInfo :: UserError -> ErrorInfo
errorInfo (UserError ErrorInfo
info) = ErrorInfo
info
instance Show UserError where show :: UserError -> String
show = forall e. Error e => String -> e -> String
showError String
"User Error"
userErr :: String -> UserError
userErr :: String -> UserError
userErr String
msg = ErrorInfo -> UserError
UserError (ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
LevelError Position
internalPos (String -> [String]
lines String
msg))
showError :: (Error e) => String -> e -> String
showError :: forall e. Error e => String -> e -> String
showError String
short_msg = String -> ErrorInfo -> String
showErrorInfo String
short_msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> ErrorInfo
errorInfo
showErrorInfo :: String -> ErrorInfo -> String
showErrorInfo :: String -> ErrorInfo -> String
showErrorInfo String
short_msg (ErrorInfo ErrorLevel
level Position
pos [String]
msgs) =
String
header forall a. [a] -> [a] -> [a]
++ [String] -> String
showMsgLines (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
short_msg then [String]
msgs else String
short_msgforall a. a -> [a] -> [a]
:[String]
msgs)
where
header :: String
header = Position -> String
showPos Position
pos forall a. [a] -> [a] -> [a]
++ String
"[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ErrorLevel
level forall a. [a] -> [a] -> [a]
++ String
"]"
showPos :: Position -> String
showPos Position
p | Position -> Bool
isSourcePos Position
p = (Position -> String
posFile Position
p) forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Position -> Int
posRow Position
pos) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
String
"(column " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Position -> Int
posColumn Position
pos) forall a. [a] -> [a] -> [a]
++ String
") "
| Bool
otherwise = forall a. Show a => a -> String
show Position
p forall a. [a] -> [a] -> [a]
++ String
":: "
showMsgLines :: [String] -> String
showMsgLines [] = forall a. String -> a
internalErr String
"No short message or error message provided."
showMsgLines (String
x:[String]
xs) = String
indent forall a. [a] -> [a] -> [a]
++ String
">>> " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
indentforall a. [a] -> [a] -> [a]
++) [String]
xs)
internalErrPrefix :: String
internalErrPrefix :: String
internalErrPrefix = [String] -> String
unlines [ String
"Language.C : Internal Error" ,
String
"This is propably a bug, and should be reported at "forall a. [a] -> [a] -> [a]
++
String
"http://www.sivity.net/projects/language.c/newticket"]
internalErr :: String -> a
internalErr :: forall a. String -> a
internalErr String
msg = forall a. HasCallStack => String -> a
error (String
internalErrPrefix forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ ShowS
indentLines String
msg
forall a. [a] -> [a] -> [a]
++ String
"\n")
indent :: String
indent :: String
indent = String
" "
indentLines :: String -> String
indentLines :: ShowS
indentLines = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String
indentforall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines