/src/Language/ObjC/Data/Error.hs
Haskell | 170 lines | 94 code | 24 blank | 52 comment | 5 complexity | f88106e46162ac65cfa234ed877a4f45 MD5 | raw file
Possible License(s): BSD-3-Clause
- {-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
- -----------------------------------------------------------------------------
- -- |
- -- Module : Language.ObjC.Data.Error
- -- Copyright : (c) 2008 Benedikt Huber, Manuel M. T. Chakravarty
- -- License : BSD-style
- -- Maintainer : jwlato@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.ObjC.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.ObjC.Data.Node
- import Language.ObjC.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.ObjC
- data ErrorInfo = ErrorInfo ErrorLevel Position [String] deriving Typeable
- -- to facilitate 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.ObjC 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.ObjC : 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