{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
module Tokstyle.C.Linter.Cast (descr) where
import Control.Monad (unless, zipWithM_)
import Data.Functor.Identity (Identity)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Language.C.Analysis.AstAnalysis (ExprSide (..), defaultMD,
tExpr)
import Language.C.Analysis.ConstEval (constEval, intValue)
import Language.C.Analysis.DefTable (lookupTag)
import Language.C.Analysis.SemRep (EnumType (..),
EnumTypeRef (..),
Enumerator (..), GlobalDecls,
IntType (..), TagDef (..),
Type (..), TypeName (..),
TypeQuals (..), noTypeQuals)
import Language.C.Analysis.TravMonad (MonadTrav, Trav, TravT,
getDefTable, throwTravError)
import Language.C.Analysis.TypeUtils (canonicalType, sameType)
import Language.C.Data.Error (userErr)
import Language.C.Data.Ident (Ident (..))
import qualified Language.C.Pretty as C
import Language.C.Syntax.AST (CConstant (..), CExpr,
CExpression (..), annotation)
import Language.C.Syntax.Constants (CInteger (..))
import Prettyprinter (pretty, (<+>))
import qualified Tokstyle.C.Env as Env
import Tokstyle.C.Env (Env, recordLinterError)
import Tokstyle.C.Patterns
import Tokstyle.C.TraverseAst (AstActions (..), astActions,
traverseAst)
import Tokstyle.C.TravUtils (backticks, getJust)
sameEnum :: Type -> Type -> (Ident, CExpr) -> (Ident, CExpr) -> TravT Env Identity ()
sameEnum :: Type
-> Type
-> (Ident, CExpr)
-> (Ident, CExpr)
-> TravT Env Identity ()
sameEnum Type
_ Type
_ (Ident
leftId, CExpr
leftExpr) (Ident
rightId, CExpr
rightExpr) = do
Integer
leftVal <- String -> Maybe Integer -> TravT Env Identity Integer
forall (m :: * -> *) a. MonadTrav m => String -> Maybe a -> m a
getJust String
failMsg (Maybe Integer -> TravT Env Identity Integer)
-> (CExpr -> Maybe Integer) -> CExpr -> TravT Env Identity Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe Integer
intValue (CExpr -> TravT Env Identity Integer)
-> TravT Env Identity CExpr -> TravT Env Identity Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MachineDesc -> Map Ident CExpr -> CExpr -> TravT Env Identity CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
defaultMD Map Ident CExpr
forall k a. Map k a
Map.empty CExpr
leftExpr
Integer
rightVal <- String -> Maybe Integer -> TravT Env Identity Integer
forall (m :: * -> *) a. MonadTrav m => String -> Maybe a -> m a
getJust String
failMsg (Maybe Integer -> TravT Env Identity Integer)
-> (CExpr -> Maybe Integer) -> CExpr -> TravT Env Identity Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Maybe Integer
intValue (CExpr -> TravT Env Identity Integer)
-> TravT Env Identity CExpr -> TravT Env Identity Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MachineDesc -> Map Ident CExpr -> CExpr -> TravT Env Identity CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
defaultMD Map Ident CExpr
forall k a. Map k a
Map.empty CExpr
rightExpr
Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
leftVal Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
rightVal) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
leftExpr) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
Doc AnsiStyle
"invalid cast: enumerator value for" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Ident -> Doc
forall p. Pretty p => p -> Doc
C.pretty Ident
leftId)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"=" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Integer
leftVal)
Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"does not match" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Ident -> Doc
forall p. Pretty p => p -> Doc
C.pretty Ident
rightId)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"=" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Integer
rightVal)
where
failMsg :: String
failMsg = String
"invalid cast: could not determine enumerator values"
checkEnumCast :: Type -> Type -> CExpr -> TravT Env Identity ()
checkEnumCast :: Type -> Type -> CExpr -> TravT Env Identity ()
checkEnumCast Type
castTy Type
exprTy CExpr
e = do
[(Ident, CExpr)]
castEnums <- Type -> TravT Env Identity [(Ident, CExpr)]
forall (m :: * -> *). MonadTrav m => Type -> m [(Ident, CExpr)]
enumerators (Type -> Type
canonicalType Type
castTy)
[(Ident, CExpr)]
exprEnums <- Type -> TravT Env Identity [(Ident, CExpr)]
forall (m :: * -> *). MonadTrav m => Type -> m [(Ident, CExpr)]
enumerators (Type -> Type
canonicalType Type
exprTy)
if [(Ident, CExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Ident, CExpr)]
castEnums Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Ident, CExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Ident, CExpr)]
exprEnums
then NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
e) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
Doc AnsiStyle
"enum types" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
castTy))) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"and"
Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
exprTy))) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"have different a number of enumerators"
else ((Ident, CExpr) -> (Ident, CExpr) -> TravT Env Identity ())
-> [(Ident, CExpr)] -> [(Ident, CExpr)] -> TravT Env Identity ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Type
-> Type
-> (Ident, CExpr)
-> (Ident, CExpr)
-> TravT Env Identity ()
sameEnum Type
castTy Type
exprTy) [(Ident, CExpr)]
castEnums [(Ident, CExpr)]
exprEnums
enumerators :: MonadTrav m => Type -> m [(Ident, CExpr)]
enumerators :: Type -> m [(Ident, CExpr)]
enumerators (DirectType (TyEnum (EnumTypeRef SUERef
name NodeInfo
_)) TypeQuals
_ Attributes
_) = do
DefTable
defs <- m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
case SUERef -> DefTable -> Maybe TagEntry
lookupTag SUERef
name DefTable
defs of
Just (Right (EnumDef (EnumType SUERef
_ [Enumerator]
enums Attributes
_ NodeInfo
_))) ->
[(Ident, CExpr)] -> m [(Ident, CExpr)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Ident, CExpr)] -> m [(Ident, CExpr)])
-> [(Ident, CExpr)] -> m [(Ident, CExpr)]
forall a b. (a -> b) -> a -> b
$ (Enumerator -> (Ident, CExpr)) -> [Enumerator] -> [(Ident, CExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Enumerator Ident
i CExpr
e EnumType
_ NodeInfo
_) -> (Ident
i, CExpr
e)) [Enumerator]
enums
Maybe TagEntry
_ ->
UserError -> m [(Ident, CExpr)]
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (UserError -> m [(Ident, CExpr)])
-> UserError -> m [(Ident, CExpr)]
forall a b. (a -> b) -> a -> b
$ String -> UserError
userErr (String -> UserError) -> String -> UserError
forall a b. (a -> b) -> a -> b
$
String
"couldn't find enum type `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall a. Show a => a -> String
show (SUERef -> Doc
forall p. Pretty p => p -> Doc
C.pretty SUERef
name) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`"
enumerators Type
ty =
UserError -> m [(Ident, CExpr)]
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (UserError -> m [(Ident, CExpr)])
-> UserError -> m [(Ident, CExpr)]
forall a b. (a -> b) -> a -> b
$ String -> UserError
userErr (String -> UserError) -> String -> UserError
forall a b. (a -> b) -> a -> b
$ String
"invalid enum type `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
ty) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`"
unqual :: Type -> Type
unqual :: Type -> Type
unqual (PtrType Type
ty TypeQuals
_ Attributes
a) = Type -> TypeQuals -> Attributes -> Type
PtrType (Type -> Type
unqual Type
ty) TypeQuals
noTypeQuals Attributes
a
unqual (DirectType TypeName
tn TypeQuals
_ Attributes
a) = TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
tn TypeQuals
noTypeQuals Attributes
a
unqual (ArrayType Type
ty ArraySize
sz TypeQuals
_ Attributes
a) = Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType (Type -> Type
unqual Type
ty) ArraySize
sz TypeQuals
noTypeQuals Attributes
a
unqual Type
ty = Type
ty
checkCast :: Type -> Type -> CExpr -> TravT Env Identity ()
checkCast :: Type -> Type -> CExpr -> TravT Env Identity ()
checkCast Type
castTy' Type
exprTy' CExpr
e
| Type -> Bool
isCharOrUint8T Type
castTy' Bool -> Bool -> Bool
&& Type -> Bool
isCharOrUint8T Type
exprTy' = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = Type -> Type -> TravT Env Identity ()
check (Type -> Type
canonicalType Type
castTy') (Type -> Type
canonicalType Type
exprTy')
where
isCharOrUint8T :: Type -> Bool
isCharOrUint8T Type
ty = case Type
ty of
Type
TY_char_ptr -> Bool
True
Type
TY_char_arr -> Bool
True
Type
TY_uint8_t_ptr -> Bool
True
Type
TY_uint8_t_arr -> Bool
True
Type
_ -> Bool
False
check :: Type -> Type -> TravT Env Identity ()
check Type
castTy Type
exprTy | Type -> Type -> Bool
sameType Type
castTy Type
exprTy = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (PtrType Type
castPointee TypeQuals
_ Attributes
_) (PtrType Type
exprPointee TypeQuals
_ Attributes
_)
| Type -> Type -> Bool
sameType (Type -> Type
unqual Type
castPointee) (Type -> Type
unqual Type
exprPointee) = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (PtrType Type
castPointee TypeQuals
_ Attributes
_) (ArrayType Type
elemTy ArraySize
_ TypeQuals
_ Attributes
_)
| Type -> Type -> Bool
sameType (Type -> Type
unqual Type
castPointee) (Type -> Type
unqual Type
elemTy) = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) Type
_ = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check PtrType{} Type
TY_void_ptr = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
TY_void_ptr PtrType{} = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check PtrType{} Type
_ | CExpr -> Bool
forall a. CExpression a -> Bool
isNullPtr CExpr
e = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
TY_sockaddr_ptr Type
TY_sockaddr_storage_ptr = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
TY_sockaddr_in_ptr Type
TY_sockaddr_storage_ptr = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
TY_sockaddr_in6_ptr Type
TY_sockaddr_storage_ptr = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
castTy Type
exprTy | Type -> Bool
isNumeric Type
castTy Bool -> Bool -> Bool
&& Type -> Bool
isNumeric Type
exprTy = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
castTy Type
exprTy | Type -> Bool
isIntegral Type
castTy Bool -> Bool -> Bool
&& Type -> Bool
isEnum Type
exprTy = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
castTy Type
exprTy | Type -> Bool
isEnum Type
castTy Bool -> Bool -> Bool
&& Type -> Bool
isEnum Type
exprTy = Type -> Type -> CExpr -> TravT Env Identity ()
checkEnumCast Type
castTy Type
exprTy CExpr
e
check (PtrType (PtrType (TY_typedef String
"Messenger") TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) Type
_ = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (PtrType Type
TY_void_ptr TypeQuals
_ Attributes
_) Type
_ = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
castTy Type
exprTy | Type -> Bool
isEnum Type
castTy Bool -> Bool -> Bool
&& Type -> Bool
isIntegral Type
exprTy = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check Type
_ Type
_ =
NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
e) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
Doc AnsiStyle
"disallowed cast from" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
exprTy'))) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"to" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
castTy')))
isNullPtr :: CExpression a -> Bool
isNullPtr (CConst (CIntConst (CInteger Integer
0 CIntRepr
_ Flags CIntFlag
_) a
_)) = Bool
True
isNullPtr CExpression a
_ = Bool
False
exemptions :: [String]
exemptions :: [String]
exemptions = [String
"call:getsockopt", String
"call:setsockopt", String
"call:bs_list_add", String
"call:bs_list_remove", String
"call:bs_list_find", String
"call:random_bytes", String
"call:randombytes"]
linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
{ doExpr :: CExpr -> TravT Env Identity () -> TravT Env Identity ()
doExpr = \CExpr
node TravT Env Identity ()
act -> case CExpr
node of
cast :: CExpr
cast@(CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_) -> do
Type
castTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
cast
Type
exprTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
[String]
ctx <- Trav Env [String]
Env.getCtx
let currentCtx :: String
currentCtx = case [String]
ctx of
(String
c:[String]
_) -> String
c
[] -> String
""
Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
currentCtx String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exemptions) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
Type -> Type -> CExpr -> TravT Env Identity ()
checkCast Type
castTy Type
exprTy CExpr
e
TravT Env Identity ()
act
CCall (CVar (Ident String
fname Int
_ NodeInfo
_) NodeInfo
_) [CExpr]
_ NodeInfo
_ -> do
String -> TravT Env Identity ()
Env.pushCtx (String -> TravT Env Identity ())
-> String -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"call:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fname
TravT Env Identity ()
act
TravT Env Identity ()
Env.popCtx
CExpr
_ -> TravT Env Identity ()
act
}
analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> TravT Env Identity ()
analyse = AstActions (TravT Env Identity)
-> GlobalDecls -> TravT Env Identity ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst AstActions (TravT Env Identity)
linter
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> TravT Env Identity (), (Text, Text))
descr = (GlobalDecls -> TravT Env Identity ()
analyse, (Text
"cast", Text
"Checks for disallowed casts between incompatible types."))