{-# 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 (CimplePos, Diagnostic)
import           Language.Cimple.Pretty      (ppNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty)
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common             (semEq, warnDoc)
import           Tokstyle.Common.Patterns


checkTypes :: Text -> FilePath -> Node (Lexeme Text) -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkTypes :: Text
-> FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
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)
-> Doc AnsiStyle
-> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
castTy (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` should not be used for `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
castTy
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"`; 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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> FilePath
-> Node (Lexeme Text)
-> Doc AnsiStyle
-> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
castTy (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
        Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` result is cast to `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
castTy
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` but allocated type is `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
sizeofTy Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"`"


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 [Diagnostic CimplePos]) Text
linter :: AstActions (State [Diagnostic CimplePos]) Text
linter = AstActions (State [Diagnostic CimplePos]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
doNode = \FilePath
file Node (Lexeme Text)
node State [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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)
-> Doc AnsiStyle
-> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"the result of `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` 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 [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
analyse :: (FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
analyse = [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos])
-> (FilePath, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [Diagnostic CimplePos] ()
 -> [Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos]
-> State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState [] (State [Diagnostic CimplePos] () -> [Diagnostic CimplePos])
-> ((FilePath, [Node (Lexeme Text)])
    -> State [Diagnostic CimplePos] ())
-> (FilePath, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Diagnostic CimplePos]) Text
-> (FilePath, [Node (Lexeme Text)])
-> State [Diagnostic CimplePos] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Diagnostic CimplePos]) Text
linter ((FilePath, [Node (Lexeme Text)])
 -> State [Diagnostic CimplePos] ())
-> ((FilePath, [Node (Lexeme Text)])
    -> (FilePath, [Node (Lexeme Text)]))
-> (FilePath, [Node (Lexeme Text)])
-> State [Diagnostic CimplePos] ()
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"
    , FilePath
"toxcore/os_memory.c"
    ]

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos],
 (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
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."
    ]))