{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Analysis.SemError
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  alpha
-- Portability :  ghc
--
-- Errors in the semantic analysis
-----------------------------------------------------------------------------
module Language.C.Analysis.SemError (
InvalidASTError(..), invalidAST,
BadSpecifierError(..), badSpecifierError,
TypeMismatch(..), typeMismatch,
RedefError(..), RedefInfo(..), RedefKind(..), redefinition,
)
where
import Data.Typeable

-- this means we cannot use SemError in SemRep, but use rich types here
import Language.C.Analysis.SemRep

import Language.C.Data.Error
import Language.C.Data.Node

-- here are the errors available

-- | InvalidASTError is caused by the violation of an invariant in the AST
newtype InvalidASTError = InvalidAST ErrorInfo deriving (Typeable)

instance Error InvalidASTError where
    errorInfo :: InvalidASTError -> ErrorInfo
errorInfo (InvalidAST ErrorInfo
ei) = ErrorInfo
ei
    changeErrorLevel :: InvalidASTError -> ErrorLevel -> InvalidASTError
changeErrorLevel (InvalidAST ErrorInfo
ei) ErrorLevel
lvl' = ErrorInfo -> InvalidASTError
InvalidAST (ErrorInfo -> ErrorLevel -> ErrorInfo
forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel ErrorInfo
ei ErrorLevel
lvl')

-- | BadSpecifierError is caused by an invalid combination of specifiers
newtype BadSpecifierError = BadSpecifierError ErrorInfo deriving (Typeable)

instance Error BadSpecifierError where
    errorInfo :: BadSpecifierError -> ErrorInfo
errorInfo (BadSpecifierError ErrorInfo
ei) = ErrorInfo
ei
    changeErrorLevel :: BadSpecifierError -> ErrorLevel -> BadSpecifierError
changeErrorLevel (BadSpecifierError ErrorInfo
ei) ErrorLevel
lvl' = ErrorInfo -> BadSpecifierError
BadSpecifierError (ErrorInfo -> ErrorLevel -> ErrorInfo
forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel ErrorInfo
ei ErrorLevel
lvl')

-- | RedefError is caused by an invalid redefinition of the same identifier or type
data RedefError = RedefError ErrorLevel RedefInfo deriving Typeable

data RedefInfo = RedefInfo String RedefKind NodeInfo NodeInfo
data RedefKind = DuplicateDef | DiffKindRedecl | ShadowedDef | DisagreeLinkage |
                 NoLinkageOld
data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) deriving Typeable

-- Invalid AST
-- ~~~~~~~~~~~

instance Show InvalidASTError  where show :: InvalidASTError -> String
show = String -> InvalidASTError -> String
forall e. Error e => String -> e -> String
showError String
"AST invariant violated"

invalidAST :: NodeInfo -> String -> InvalidASTError
invalidAST :: NodeInfo -> String -> InvalidASTError
invalidAST NodeInfo
node_info String
msg = ErrorInfo -> InvalidASTError
InvalidAST (ErrorLevel -> String -> NodeInfo -> ErrorInfo
mkErrorInfo ErrorLevel
LevelError String
msg NodeInfo
node_info)

-- Bad specifier (e.g. static for a parameter, or extern when there is an initializer)
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

instance Show BadSpecifierError     where show :: BadSpecifierError -> String
show = String -> BadSpecifierError -> String
forall e. Error e => String -> e -> String
showError String
"Bad specifier"

badSpecifierError :: NodeInfo -> String -> BadSpecifierError
badSpecifierError :: NodeInfo -> String -> BadSpecifierError
badSpecifierError NodeInfo
node_info String
msg = ErrorInfo -> BadSpecifierError
BadSpecifierError (ErrorLevel -> String -> NodeInfo -> ErrorInfo
mkErrorInfo ErrorLevel
LevelError String
msg NodeInfo
node_info)

-- Type mismatch
-- ~~~~~~~~~~~~~
typeMismatch :: String -> (NodeInfo, Type) -> (NodeInfo,Type) -> TypeMismatch
typeMismatch :: String -> (NodeInfo, Type) -> (NodeInfo, Type) -> TypeMismatch
typeMismatch = String -> (NodeInfo, Type) -> (NodeInfo, Type) -> TypeMismatch
TypeMismatch

instance Show TypeMismatch where
    show :: TypeMismatch -> String
show TypeMismatch
tm = String -> ErrorInfo -> String
forall e. Error e => String -> e -> String
showError String
"Type mismatch" (TypeMismatch -> ErrorInfo
typeMismatchInfo TypeMismatch
tm)
instance Error TypeMismatch where
    errorInfo :: TypeMismatch -> ErrorInfo
errorInfo = TypeMismatch -> ErrorInfo
typeMismatchInfo
typeMismatchInfo :: TypeMismatch -> ErrorInfo
typeMismatchInfo :: TypeMismatch -> ErrorInfo
typeMismatchInfo (TypeMismatch String
reason (NodeInfo
node1,Type
_ty2) (NodeInfo, Type)
_t2) =
    ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
LevelError (NodeInfo -> Position
posOfNode NodeInfo
node1) [String
reason]

-- Redefinitions
-- ~~~~~~~~~~~~~

instance Show RedefError  where
    show :: RedefError -> String
show (RedefError ErrorLevel
lvl RedefInfo
info) = String -> ErrorInfo -> String
showErrorInfo (RedefInfo -> String
redefErrLabel RedefInfo
info) (ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo ErrorLevel
lvl RedefInfo
info)
instance Error RedefError where
    errorInfo :: RedefError -> ErrorInfo
errorInfo (RedefError ErrorLevel
lvl RedefInfo
info) = ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo ErrorLevel
lvl RedefInfo
info
    changeErrorLevel :: RedefError -> ErrorLevel -> RedefError
changeErrorLevel (RedefError ErrorLevel
_lvl RedefInfo
info) ErrorLevel
lvl' = ErrorLevel -> RedefInfo -> RedefError
RedefError ErrorLevel
lvl' RedefInfo
info

redefErrLabel :: RedefInfo -> String
redefErrLabel :: RedefInfo -> String
redefErrLabel  (RedefInfo String
ident RedefKind
_ NodeInfo
_ NodeInfo
_) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" redefined"

redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo ErrorLevel
lvl info :: RedefInfo
info@(RedefInfo String
_ RedefKind
_ NodeInfo
node NodeInfo
old_node) =
    ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
lvl (NodeInfo -> Position
posOfNode NodeInfo
node) ([RedefInfo -> String
redefErrReason RedefInfo
info] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ NodeInfo -> [String]
prevDeclMsg NodeInfo
old_node)

redefErrReason :: RedefInfo -> String
redefErrReason :: RedefInfo -> String
redefErrReason (RedefInfo String
ident RedefKind
DuplicateDef NodeInfo
_ NodeInfo
_) = String
"duplicate definition of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ident
redefErrReason (RedefInfo String
ident RedefKind
ShadowedDef NodeInfo
_ NodeInfo
_)   = String
"this declaration of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" shadows a previous one"
redefErrReason (RedefInfo String
ident RedefKind
DiffKindRedecl NodeInfo
_ NodeInfo
_) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" previously declared as a different kind of symbol"
redefErrReason (RedefInfo String
ident RedefKind
DisagreeLinkage NodeInfo
_ NodeInfo
_) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" previously declared with different linkage"
redefErrReason (RedefInfo String
ident RedefKind
NoLinkageOld NodeInfo
_ NodeInfo
_) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" previously declared without linkage"

prevDeclMsg :: NodeInfo -> [String]
prevDeclMsg :: NodeInfo -> [String]
prevDeclMsg NodeInfo
old_node = [String
"The previous declaration was here: ", Position -> String
forall a. Show a => a -> String
show (NodeInfo -> Position
posOfNode NodeInfo
old_node)]

redefinition :: ErrorLevel -> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition :: ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
lvl String
ctx RedefKind
kind NodeInfo
new NodeInfo
old = ErrorLevel -> RedefInfo -> RedefError
RedefError ErrorLevel
lvl (String -> RedefKind -> NodeInfo -> NodeInfo -> RedefInfo
RedefInfo String
ctx RedefKind
kind NodeInfo
new NodeInfo
old)