SemError.hs

{-# 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

-- 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

instance Error InvalidASTError where
    errorInfo (InvalidAST ei) = ei
    changeErrorLevel (InvalidAST ei) lvl' = InvalidAST (changeErrorLevel ei lvl')

-- | BadSpecifierError is caused by an invalid combination of specifiers
newtype BadSpecifierError = BadSpecifierError ErrorInfo

instance Error BadSpecifierError where
    errorInfo (BadSpecifierError ei) = ei
    changeErrorLevel (BadSpecifierError ei) lvl' = BadSpecifierError (changeErrorLevel ei lvl')

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

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

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

instance Show InvalidASTError  where show = showError "AST invariant violated"

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

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

instance Show BadSpecifierError     where show = showError "Bad specifier"

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

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

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

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

instance Show RedefError  where
    show (RedefError lvl info) = showErrorInfo (redefErrLabel info) (redefErrorInfo lvl info)
instance Error RedefError where
    errorInfo (RedefError lvl info) = redefErrorInfo lvl info
    changeErrorLevel (RedefError _lvl info) lvl' = RedefError lvl' info

redefErrLabel :: RedefInfo -> String
redefErrLabel  (RedefInfo ident _ _ _) = ident ++ " redefined"

redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo
redefErrorInfo lvl info@(RedefInfo _ _ node old_node) =
    ErrorInfo lvl (posOfNode node) ([redefErrReason info] ++ prevDeclMsg old_node)

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

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

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