{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.C.Linter.Memcpy (descr) where

import           Control.Monad                   (unless)
import           Data.Functor.Identity           (Identity)
import           Data.Text                       (Text)
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemRep      (CompTypeRef (CompTypeRef),
                                                  EnumTypeRef (EnumTypeRef),
                                                  GlobalDecls,
                                                  IntType (TyUChar), Type (..),
                                                  TypeName (TyComp, TyEnum, TyIntegral, TyVoid))
import           Language.C.Analysis.TravMonad   (Trav, TravT)
import           Language.C.Analysis.TypeUtils   (canonicalType)
import           Language.C.Data.Ident           (Ident (..))
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST           (CExpr, CExpression (..),
                                                  annotation)
import           Prettyprinter                   (pretty, (<+>))
import           Tokstyle.C.Env                  (Env, recordLinterError)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)

compatibleType :: Type -> Type -> Bool
compatibleType :: Type -> Type -> Bool
compatibleType Type
TY_sockaddr_storage_ptr Type
TY_sockaddr_ptr     = Bool
True
compatibleType Type
TY_sockaddr_storage_ptr Type
TY_sockaddr_in_ptr  = Bool
True
compatibleType Type
TY_sockaddr_storage_ptr Type
TY_sockaddr_in6_ptr = Bool
True
compatibleType Type
TY_sockaddr_ptr         Type
TY_sockaddr_storage_ptr = Bool
True
compatibleType Type
TY_sockaddr_in_ptr      Type
TY_sockaddr_storage_ptr = Bool
True
compatibleType Type
TY_sockaddr_in6_ptr     Type
TY_sockaddr_storage_ptr = Bool
True
compatibleType (PtrType    Type
a TypeQuals
_ Attributes
_  ) (PtrType    Type
b TypeQuals
_ Attributes
_  ) = Type -> Type -> Bool
compatibleType Type
a Type
b
compatibleType (ArrayType  Type
a ArraySize
_ TypeQuals
_ Attributes
_) (PtrType    Type
b TypeQuals
_ Attributes
_  ) = Type -> Type -> Bool
compatibleType Type
a Type
b
compatibleType (PtrType    Type
a TypeQuals
_ Attributes
_  ) (ArrayType  Type
b ArraySize
_ TypeQuals
_ Attributes
_) = Type -> Type -> Bool
compatibleType Type
a Type
b
compatibleType (ArrayType  Type
a ArraySize
_ TypeQuals
_ Attributes
_) (ArrayType  Type
b ArraySize
_ TypeQuals
_ Attributes
_) = Type -> Type -> Bool
compatibleType Type
a Type
b
compatibleType (DirectType TypeName
a TypeQuals
_ Attributes
_  ) (DirectType TypeName
b TypeQuals
_ Attributes
_  ) = TypeName -> TypeName -> Bool
compatibleTypeName TypeName
a TypeName
b
compatibleType Type
_ Type
_                                       = Bool
False

compatibleTypeName :: TypeName -> TypeName -> Bool
-- `uint8_t*` can can be memcpy'd to and from anything.
compatibleTypeName :: TypeName -> TypeName -> Bool
compatibleTypeName (TyIntegral IntType
TyUChar) TypeName
_ = Bool
True
compatibleTypeName TypeName
_ (TyIntegral IntType
TyUChar) = Bool
True
-- Integral types can only be memcpy'd to the same integral type.
compatibleTypeName (TyIntegral IntType
a) (TyIntegral IntType
b) = IntType
a IntType -> IntType -> Bool
forall a. Eq a => a -> a -> Bool
== IntType
b
-- Structs can only be memcpy'd to the exact same struct.
compatibleTypeName (TyComp (CompTypeRef SUERef
a CompTyKind
_ NodeInfo
_)) (TyComp (CompTypeRef SUERef
b CompTyKind
_ NodeInfo
_)) = SUERef
a SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
== SUERef
b
-- Enums can only be memcpy'd to the exact same enum.
compatibleTypeName (TyEnum (EnumTypeRef SUERef
a NodeInfo
_)) (TyEnum (EnumTypeRef SUERef
b NodeInfo
_)) = SUERef
a SUERef -> SUERef -> Bool
forall a. Eq a => a -> a -> Bool
== SUERef
b
-- Void pointers are disallowed.
compatibleTypeName TypeName
TyVoid TypeName
_ = Bool
False
compatibleTypeName TypeName
_ TypeName
TyVoid = Bool
False
-- Everything else is disallowed.
compatibleTypeName TypeName
_ TypeName
_ = Bool
False

validMemType :: Type -> Bool
validMemType :: Type -> Bool
validMemType (PtrType   DirectType{} TypeQuals
_ Attributes
_  ) = Bool
True
validMemType (ArrayType DirectType{} ArraySize
_ TypeQuals
_ Attributes
_) = Bool
True
validMemType Type
_                              = Bool
False

checkMemType :: String -> CExpr -> Type -> Trav Env ()
checkMemType :: String -> CExpr -> Type -> Trav Env ()
checkMemType String
fname CExpr
expr Type
ty =
    Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Bool
validMemType (Type -> Type
canonicalType Type
ty)) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
        NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
expr) (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
fname) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"argument type" 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
ty)))
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is not a valid memory type (pointers to arrays are not allowed)"

checkCompatibility :: String -> CExpr -> CExpr -> Trav Env ()
checkCompatibility :: String -> CExpr -> CExpr -> Trav Env ()
checkCompatibility String
fname CExpr
dst CExpr
src = do
    Type
dstTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
dst
    Type
srcTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
src
    String -> CExpr -> Type -> Trav Env ()
checkMemType String
fname CExpr
dst Type
dstTy
    String -> CExpr -> Type -> Trav Env ()
checkMemType String
fname CExpr
src Type
srcTy
    Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Type -> Bool
compatibleType (Type -> Type
canonicalType Type
dstTy) (Type -> Type
canonicalType Type
srcTy)) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
        NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
dst) (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
fname) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"first argument type" 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
dstTy)))
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is not compatible with second argument type"
            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
srcTy)))

linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doExpr :: CExpr -> Trav Env () -> Trav Env ()
doExpr = \CExpr
node Trav Env ()
act -> case CExpr
node of
        CCall (CVar (Ident String
fname Int
_ NodeInfo
_) NodeInfo
_) [CExpr
dst, CExpr
src, CExpr
_] NodeInfo
_ | String
fname String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"memcpy", String
"memmove", String
"memcmp"] -> do
            String -> CExpr -> CExpr -> Trav Env ()
checkCompatibility String
fname CExpr
dst CExpr
src
            Trav Env ()
act

        CExpr
_ -> Trav Env ()
act
    }

analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse = AstActions (TravT Env Identity) -> GlobalDecls -> Trav Env ()
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 -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"memcpy", Text
"Checks compatibility of dst and src in memcpy/memcmp."))