{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Data.Error
-- Copyright   :  (c) 2008 Benedikt Huber, Manuel M. T. Chakravarty
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  experimental
-- Portability :  ghc
--
-- Base type for errors occurring in parsing, analysing and pretty-printing.
-- With ideas from Simon Marlow's
-- "An extensible dynamically-typed hierarchy of execeptions [2006]"
-----------------------------------------------------------------------------
module Language.C.Data.Error (
    -- * Severity Level
    ErrorLevel(..), isHardError,
    -- * Error class
    Error(..), errorPos, errorLevel, errorMsgs,
    -- * Error 'supertype'
    CError(..),
    -- * Infos attached to errors
    ErrorInfo(..),showError,showErrorInfo,mkErrorInfo,
    -- * Default error types
    UnsupportedFeature, unsupportedFeature, unsupportedFeature_,
    UserError, userErr,
    -- * Raising internal errors
    internalErr,
)
where
import Data.Typeable
import Language.C.Data.Node
import Language.C.Data.Position

-- | Error levels (severity)
data ErrorLevel = LevelWarn
                | LevelError
                | LevelFatal
              deriving (ErrorLevel -> ErrorLevel -> Bool
(ErrorLevel -> ErrorLevel -> Bool)
-> (ErrorLevel -> ErrorLevel -> Bool) -> Eq ErrorLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorLevel -> ErrorLevel -> Bool
== :: ErrorLevel -> ErrorLevel -> Bool
$c/= :: ErrorLevel -> ErrorLevel -> Bool
/= :: ErrorLevel -> ErrorLevel -> Bool
Eq, Eq ErrorLevel
Eq ErrorLevel =>
(ErrorLevel -> ErrorLevel -> Ordering)
-> (ErrorLevel -> ErrorLevel -> Bool)
-> (ErrorLevel -> ErrorLevel -> Bool)
-> (ErrorLevel -> ErrorLevel -> Bool)
-> (ErrorLevel -> ErrorLevel -> Bool)
-> (ErrorLevel -> ErrorLevel -> ErrorLevel)
-> (ErrorLevel -> ErrorLevel -> ErrorLevel)
-> Ord 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
$ccompare :: ErrorLevel -> ErrorLevel -> Ordering
compare :: ErrorLevel -> ErrorLevel -> Ordering
$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
>= :: ErrorLevel -> ErrorLevel -> Bool
$cmax :: ErrorLevel -> ErrorLevel -> ErrorLevel
max :: ErrorLevel -> ErrorLevel -> ErrorLevel
$cmin :: ErrorLevel -> ErrorLevel -> ErrorLevel
min :: ErrorLevel -> ErrorLevel -> ErrorLevel
Ord)

instance Show ErrorLevel where
    show :: ErrorLevel -> String
show ErrorLevel
LevelWarn  = String
"WARNING"
    show ErrorLevel
LevelError = String
"ERROR"
    show ErrorLevel
LevelFatal = String
"FATAL ERROR"

-- | return @True@ when the given error makes it impossible to continue
--   analysis or compilation.
isHardError :: (Error ex) => ex -> Bool
isHardError :: forall ex. Error ex => ex -> Bool
isHardError = ( ErrorLevel -> ErrorLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ErrorLevel
LevelWarn) (ErrorLevel -> Bool) -> (ex -> ErrorLevel) -> ex -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ex -> ErrorLevel
forall e. Error e => e -> ErrorLevel
errorLevel

-- | information attached to every error in Language.C
data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable

-- to facilitate newtype deriving
instance Show ErrorInfo where show :: ErrorInfo -> String
show = String -> ErrorInfo -> String
showErrorInfo String
"error"
instance Error ErrorInfo where
    errorInfo :: ErrorInfo -> 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)

-- | `supertype' of all errors
data CError
    = forall err. (Error err) => CError err
    deriving Typeable

-- | errors in Language.C are instance of 'Error'
class (Typeable e, Show e) => Error e where
    -- | obtain source location etc. of an error
    errorInfo        :: e -> ErrorInfo
    -- | wrap error in 'CError'
    toError          :: e -> CError
    -- | try to cast a generic 'CError' to the specific error type
    fromError     :: CError -> (Maybe e)
    -- | modify the error level
    changeErrorLevel :: e -> ErrorLevel -> e

    -- default implementation
    fromError (CError err
e) = err -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast err
e
    toError = e -> CError
forall err. Error err => err -> CError
CError
    changeErrorLevel e
e ErrorLevel
lvl =
        if e -> ErrorLevel
forall e. Error e => e -> ErrorLevel
errorLevel e
e ErrorLevel -> ErrorLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorLevel
lvl
            then e
e
            else String -> e
forall a. HasCallStack => String -> a
error (String -> e) -> String -> e
forall a b. (a -> b) -> a -> b
$ String
"changeErrorLevel: not possible for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e

instance Show CError where
    show :: CError -> String
show (CError err
e) = err -> String
forall a. Show a => a -> String
show err
e
instance Error CError where
    errorInfo :: CError -> ErrorInfo
errorInfo (CError err
err) = err -> ErrorInfo
forall e. Error e => e -> ErrorInfo
errorInfo err
err
    toError :: CError -> CError
toError = CError -> CError
forall a. a -> a
id
    fromError :: CError -> Maybe CError
fromError = CError -> Maybe CError
forall a. a -> Maybe a
Just
    changeErrorLevel :: CError -> ErrorLevel -> CError
changeErrorLevel (CError err
e) = err -> CError
forall err. Error err => err -> CError
CError (err -> CError) -> (ErrorLevel -> err) -> ErrorLevel -> CError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> ErrorLevel -> err
forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel err
e

-- | position of an @Error@
errorPos   :: (Error e) => e -> Position
errorPos :: forall e. Error e => e -> Position
errorPos = ( \(ErrorInfo ErrorLevel
_ Position
pos [String]
_) -> Position
pos ) (ErrorInfo -> Position) -> (e -> ErrorInfo) -> e -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorInfo
forall e. Error e => e -> ErrorInfo
errorInfo

-- | severity level of an @Error@
errorLevel :: (Error e) => e -> ErrorLevel
errorLevel :: forall e. Error e => e -> ErrorLevel
errorLevel = ( \(ErrorInfo ErrorLevel
lvl Position
_ [String]
_) -> ErrorLevel
lvl ) (ErrorInfo -> ErrorLevel) -> (e -> ErrorInfo) -> e -> ErrorLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorInfo
forall e. Error e => e -> ErrorInfo
errorInfo

-- | message lines of an @Error@
errorMsgs   :: (Error e) => e -> [String]
errorMsgs :: forall e. Error e => e -> [String]
errorMsgs = ( \(ErrorInfo ErrorLevel
_ Position
_ [String]
msgs) -> [String]
msgs ) (ErrorInfo -> [String]) -> (e -> ErrorInfo) -> e -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorInfo
forall e. Error e => e -> ErrorInfo
errorInfo

-- | error raised if a operation requires an unsupported or not yet implemented feature.
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 = String -> UnsupportedFeature -> String
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 (a -> Position
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

-- | unspecified error raised by the user (in case the user does not want to define
--   her own error types).
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 = String -> UserError -> String
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))

-- other errors to be defined elsewhere

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 (ErrorInfo -> String) -> (e -> ErrorInfo) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorInfo
forall e. Error e => e -> ErrorInfo
errorInfo

-- | converts an error into a string using a fixed format
--
-- * either the lines of the long error message or the short message has to be non-empty
--
-- * the format is
--
-- >    <fname>:<row>: (column <col>) [<err lvl>]
-- >      >>> <line_1>
-- >      <line_2>
-- >        ...
-- >      <line_n>
showErrorInfo :: String -> ErrorInfo -> String
showErrorInfo :: String -> ErrorInfo -> String
showErrorInfo String
short_msg (ErrorInfo ErrorLevel
level Position
pos [String]
msgs) =
    String
header String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
showMsgLines (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
short_msg then [String]
msgs else String
short_msgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
msgs)
    where
    header :: String
header = Position -> String
showPos Position
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorLevel -> String
forall a. Show a => a -> String
show ErrorLevel
level String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    showPos :: Position -> String
showPos Position
p | Position -> Bool
isSourcePos Position
p = (Position -> String
posFile Position
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Position -> Int
posRow Position
pos) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                String
"(column " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Position -> Int
posColumn Position
pos) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") "
              | Bool
otherwise = Position -> String
forall a. Show a => a -> String
show Position
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":: "
    showMsgLines :: [String] -> String
showMsgLines []     = ShowS
forall a. String -> a
internalErr String
"No short message or error message provided."
    showMsgLines (String
x:[String]
xs) = String
indent String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">>> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
indentString -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
xs)


-- internal errors
internalErrPrefix :: String
internalErrPrefix :: String
internalErrPrefix = [String] -> String
unlines [ String
"Language.C : Internal Error" ,
                              String
"This is propably a bug, and should be reported at "String -> ShowS
forall a. [a] -> [a] -> [a]
++
                              String
"http://www.sivity.net/projects/language.c/newticket"]

-- | raise a fatal internal error; message may have multiple lines
internalErr     :: String -> a
internalErr :: forall a. String -> a
internalErr String
msg  = String -> a
forall a. HasCallStack => String -> a
error (String
internalErrPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
indentLines String
msg
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
indent :: String
indent :: String
indent = String
"  "
indentLines :: String -> String
indentLines :: ShowS
indentLines = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
indentString -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines