{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.CallocType (descr) where

import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), Node, NodeF (..),
                                              Scope (..))
import           Language.Cimple.Diagnostics (warn)
import           Language.Cimple.Pretty      (showNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common             (semEq)
import           Tokstyle.Common.Patterns


checkTypes :: Text -> FilePath -> Node (Lexeme Text) -> Node (Lexeme Text) -> State [Text] ()
checkTypes :: Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
castTy of
    TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
_ Text
tyName))) | Bool -> Bool
not (Text
"pthread_" Text -> Text -> Bool
`Text.isPrefixOf` Text
tyName) ->
        FilePath -> Node (Lexeme Text) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
castTy (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
            Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should not be used for `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
castTy
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`; use `mem_balloc` instead"
    TyPointer Node (Lexeme Text)
ty1 | Node (Lexeme Text)
ty1 Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
`semEq` Node (Lexeme Text)
sizeofTy -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TyOwner (Fix (TyPointer Node (Lexeme Text)
ty1)) | Node (Lexeme Text)
ty1 Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
`semEq` Node (Lexeme Text)
sizeofTy -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> FilePath -> Node (Lexeme Text) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
castTy (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
        Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` result is cast to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
castTy
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` but allocated type is `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
sizeofTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"


pattern Calloc :: Text -> [Node (Lexeme Text)] -> Node (Lexeme Text)
pattern $mCalloc :: forall r.
Node (Lexeme Text)
-> (Text -> [Node (Lexeme Text)] -> r) -> (Void# -> r) -> r
Calloc funName args <- Fix (FunctionCall (Fix (VarExpr (L _ _ funName))) args)

pattern CallocCast :: Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Node (Lexeme Text)
pattern $mCallocCast :: forall r.
Node (Lexeme Text)
-> (Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> r)
-> (Void# -> r)
-> r
CallocCast castTy funName args <- Fix (CastExpr castTy (Calloc funName args))

isCalloc :: Text -> Bool
isCalloc :: Text -> Bool
isCalloc Text
"calloc"       = Bool
True
isCalloc Text
"realloc"      = Bool
True
isCalloc Text
"mem_alloc"    = Bool
True
isCalloc Text
"mem_valloc"   = Bool
True
isCalloc Text
"mem_vrealloc" = Bool
True
isCalloc Text
_              = Bool
False

linter :: AstActions (State [Text]) Text
linter :: AstActions (State [Text]) Text
linter = AstActions (State [Text]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text) -> State [Text] () -> State [Text] ()
doNode = \FilePath
file Node (Lexeme Text)
node State [Text] ()
act -> case Node (Lexeme Text)
node of
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"calloc" [Node (Lexeme Text)
_, Fix (SizeofType Node (Lexeme Text)
sizeofTy)] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"calloc" [Node (Lexeme Text)
_, Fix (BinaryExpr Node (Lexeme Text)
_ BinaryOp
_ (Fix (SizeofType Node (Lexeme Text)
sizeofTy)))] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"realloc" [Node (Lexeme Text)
_, Fix (BinaryExpr Node (Lexeme Text)
_ BinaryOp
_ (Fix (SizeofType Node (Lexeme Text)
sizeofTy)))] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"mem_alloc" [Node (Lexeme Text)
_, Fix (SizeofType Node (Lexeme Text)
sizeofTy)] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"mem_valloc" [Node (Lexeme Text)
_, Node (Lexeme Text)
_, Fix (SizeofType Node (Lexeme Text)
sizeofTy)] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy
        CallocCast Node (Lexeme Text)
castTy funName :: Text
funName@Text
"mem_vrealloc" [Node (Lexeme Text)
_, Node (Lexeme Text)
_, Node (Lexeme Text)
_, Fix (SizeofType Node (Lexeme Text)
sizeofTy)] ->
            Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkTypes Text
funName FilePath
file Node (Lexeme Text)
castTy Node (Lexeme Text)
sizeofTy

        Calloc Text
funName [Node (Lexeme Text)]
_ | Text -> Bool
isCalloc Text
funName ->
            FilePath -> Node (Lexeme Text) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
node (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"the result of `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` must be cast to its member type"

        Fix (FunctionDefn Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
TY_void_ptr Lexeme Text
_ [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_) ->
            -- Ignore static functions returning void pointers. These are allocator
            -- functions from mem.c.
            () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        Node (Lexeme Text)
_ -> State [Text] ()
act
    }

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> [Text])
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [Text] () -> [Text] -> [Text])
-> [Text] -> State [Text] () -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Text] () -> [Text] -> [Text]
forall s a. State s a -> s -> s
State.execState [] (State [Text] () -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> State [Text] ())
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Text]) Text
-> (FilePath, [Node (Lexeme Text)]) -> State [Text] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Text]) Text
linter ((FilePath, [Node (Lexeme Text)]) -> State [Text] ())
-> ((FilePath, [Node (Lexeme Text)])
    -> (FilePath, [Node (Lexeme Text)]))
-> (FilePath, [Node (Lexeme Text)])
-> State [Text] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> (FilePath, [Node (Lexeme Text)])
-> (FilePath, [Node (Lexeme Text)])
Common.skip
    [ FilePath
"toxav/rtp.c"
    , FilePath
"toxcore/list.c"
    , FilePath
"toxcore/mem.c"
    ]

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"calloc-type", [Text] -> Text
Text.unlines
    [ Text
"Checks that `mem_alloc` and other `calloc`-like functions are cast to the"
    , Text
"correct type. The types in the `sizeof` expression and the type-cast expression"
    , Text
"must be the same. Also, `calloc`-like functions should not be used for built-in"
    , Text
"types such as `uint8_t` arrays. For this, use `mem_balloc`, instead."
    , Text
""
    , Text
"**Reason:** ensures that the allocation size is appropriate for the allocated"
    , Text
"object. This makes allocation functions behave more like C++ `new`. For byte"
    , Text
"arrays, we provide a separate function that doesn't need to zero out its memory"
    , Text
"for efficiency and to make it easier to detect logic errors using msan or"
    , Text
"valgrind that can detect uninitialised memory use."
    ]))