{-# 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 ei :: ErrorInfo
ei) = ErrorInfo
ei
    changeErrorLevel :: InvalidASTError -> ErrorLevel -> InvalidASTError
changeErrorLevel (InvalidAST ei :: ErrorInfo
ei) lvl' :: 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 ei :: ErrorInfo
ei) = ErrorInfo
ei
    changeErrorLevel :: BadSpecifierError -> ErrorLevel -> BadSpecifierError
changeErrorLevel (BadSpecifierError ei :: ErrorInfo
ei) lvl' :: 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 "AST invariant violated"

invalidAST :: NodeInfo -> String -> InvalidASTError
invalidAST :: NodeInfo -> String -> InvalidASTError
invalidAST node_info :: NodeInfo
node_info msg :: 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 "Bad specifier"

badSpecifierError :: NodeInfo -> String -> BadSpecifierError
badSpecifierError :: NodeInfo -> String -> BadSpecifierError
badSpecifierError node_info :: NodeInfo
node_info msg :: 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 tm :: TypeMismatch
tm = String -> ErrorInfo -> String
forall e. Error e => String -> e -> String
showError "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 reason :: String
reason (node1 :: NodeInfo
node1,_ty2 :: Type
_ty2) _t2 :: (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 lvl :: ErrorLevel
lvl info :: 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 lvl :: ErrorLevel
lvl info :: RedefInfo
info) = ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo ErrorLevel
lvl RedefInfo
info
    changeErrorLevel :: RedefError -> ErrorLevel -> RedefError
changeErrorLevel (RedefError _lvl :: ErrorLevel
_lvl info :: RedefInfo
info) lvl' :: ErrorLevel
lvl' = ErrorLevel -> RedefInfo -> RedefError
RedefError ErrorLevel
lvl' RedefInfo
info

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

redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo lvl :: ErrorLevel
lvl info :: RedefInfo
info@(RedefInfo _ _ node :: NodeInfo
node old_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 ident :: String
ident DuplicateDef _ _) = "duplicate definition of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ident
redefErrReason (RedefInfo ident :: String
ident ShadowedDef _ _)   = "this declaration of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ " shadows a previous one"
redefErrReason (RedefInfo ident :: String
ident DiffKindRedecl _ _) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ " previously declared as a different kind of symbol"
redefErrReason (RedefInfo ident :: String
ident DisagreeLinkage _ _) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ " previously declared with different linkage"
redefErrReason (RedefInfo ident :: String
ident NoLinkageOld _ _) = String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ " previously declared without linkage"

prevDeclMsg :: NodeInfo -> [String]
prevDeclMsg :: NodeInfo -> [String]
prevDeclMsg old_node :: NodeInfo
old_node = ["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 lvl :: ErrorLevel
lvl ctx :: String
ctx kind :: RedefKind
kind new :: NodeInfo
new old :: NodeInfo
old = ErrorLevel -> RedefInfo -> RedefError
RedefError ErrorLevel
lvl (String -> RedefKind -> NodeInfo -> NodeInfo -> RedefInfo
RedefInfo String
ctx RedefKind
kind NodeInfo
new NodeInfo
old)