Error.hs

{-# 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 occuring 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 Data.Generics
import Language.C.Data.Node
import Language.C.Data.Position

-- | Error levels (severity)
data ErrorLevel = LevelWarn
                | LevelError
                | LevelFatal
              deriving (Eq, Ord)

instance Show ErrorLevel where
    show LevelWarn  = "WARNING"
    show LevelError = "ERROR"
    show LevelFatal = "FATAL ERROR"

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

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

-- to faciliate newtype deriving
instance Show ErrorInfo where show = showErrorInfo "error"
instance Error ErrorInfo where
    errorInfo = id
    changeErrorLevel (ErrorInfo _ pos msgs) lvl' = ErrorInfo lvl' pos msgs

mkErrorInfo :: ErrorLevel -> String -> NodeInfo -> ErrorInfo
mkErrorInfo lvl msg node = ErrorInfo lvl (posOfNode node) (lines 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 e) = cast e
    toError = CError
    changeErrorLevel e lvl =
        if errorLevel e == lvl
            then e
            else error $ "changeErrorLevel: not possible for " ++ show e

instance Show CError where
    show (CError e) = show e
instance Error CError where
    errorInfo (CError err) = errorInfo err
    toError = id
    fromError = Just
    changeErrorLevel (CError e) = CError . changeErrorLevel e

-- | position of an @Error@
errorPos   :: (Error e) => e -> Position
errorPos = ( \(ErrorInfo _ pos _) -> pos ) . errorInfo

-- | severity level of an @Error@
errorLevel :: (Error e) => e -> ErrorLevel
errorLevel = ( \(ErrorInfo lvl _ _) -> lvl ) . errorInfo

-- | message lines of an @Error@
errorMsgs   :: (Error e) => e -> [String]
errorMsgs = ( \(ErrorInfo _ _ msgs) -> msgs ) . 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 msg pos) = ErrorInfo LevelError pos (lines msg)
instance Show UnsupportedFeature where show = showError "Unsupported Feature"

unsupportedFeature :: (Pos a) => String -> a -> UnsupportedFeature
unsupportedFeature msg a = UnsupportedFeature msg (posOf a)

unsupportedFeature_ :: String -> UnsupportedFeature
unsupportedFeature_ msg = UnsupportedFeature msg 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 info) = info
instance Show UserError where show = showError "User Error"

userErr :: String -> UserError
userErr msg = UserError (ErrorInfo LevelError internalPos (lines msg))

-- other errors to be defined elsewhere

showError :: (Error e) => String -> e -> String
showError short_msg = showErrorInfo short_msg . 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 short_msg (ErrorInfo level pos msgs) =
    header ++ showMsgLines (if null short_msg then msgs else short_msg:msgs)
    where
    header = (posFile pos) ++ ":" ++ show (posRow pos) ++ ": " ++
             "(column " ++ show (posColumn pos) ++ ") " ++
             "[" ++ show level ++ "]"
    showMsgLines []     = internalErr "No short message or error message provided."
    showMsgLines (x:xs) = indent ++ ">>> " ++ x ++ "\n" ++ unlines (map (indent++) xs)


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

-- | raise a fatal internal error; message may have multiple lines
internalErr     :: String -> a
internalErr msg  = error (internalErrPrefix ++ "\n"
                       ++ indentLines msg
                       ++ "\n")
indent :: String
indent = "  "
indentLines :: String -> String
indentLines = unlines . map (indent++) . lines