{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.CallocArgs (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             (BinaryOp (BopMul), Lexeme (..),
                                              Node, NodeF (..), Scope (..))
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty, (<+>))
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common             (backticks, warn, warnDoc)
import           Tokstyle.Common.Patterns


checkSize, checkNmemb :: Text -> FilePath -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkSize :: Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
size of
    SizeofType{} -> () -> 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)
size (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks Doc AnsiStyle
"size" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"argument in call 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 (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"must be a sizeof expression"

checkNmemb :: Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
nmemb of
    LiteralExpr{}     -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    VarExpr{}         -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ParenExpr Node (Lexeme Text)
e       -> Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
e
    PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
e
    BinaryExpr Node (Lexeme Text)
l BinaryOp
_ Node (Lexeme Text)
r -> do
        Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
l
        Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
r

    SizeofType{} ->
        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)
nmemb (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks Doc AnsiStyle
"sizeof" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"should not appear in the" 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 Doc AnsiStyle
"nmemb" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"argument 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 (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName)

    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)
nmemb (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid expression in" 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 Doc AnsiStyle
"nmemb" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"argument 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 (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funName)


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)

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
        Calloc funName :: Text
funName@Text
"calloc" [Node (Lexeme Text)
nmemb, Node (Lexeme Text)
size] -> do
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size
        Calloc funName :: Text
funName@Text
"realloc" [Node (Lexeme Text)
_, Fix (BinaryExpr Node (Lexeme Text)
nmemb BinaryOp
BopMul Node (Lexeme Text)
size)] -> do
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size
        Calloc funName :: Text
funName@Text
"mem_alloc" [Node (Lexeme Text)
_, Node (Lexeme Text)
size] -> do
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size
        Calloc funName :: Text
funName@Text
"mem_valloc" [Node (Lexeme Text)
_, Node (Lexeme Text)
nmemb, Node (Lexeme Text)
size] -> do
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size
        Calloc funName :: Text
funName@Text
"mem_vrealloc" [Node (Lexeme Text)
_, Node (Lexeme Text)
_, Node (Lexeme Text)
nmemb, Node (Lexeme Text)
size] -> do
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text
-> FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size

        Calloc Text
"calloc"       [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)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid" 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 Doc AnsiStyle
"calloc" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"invocation: 2 arguments expected"
        Calloc Text
"realloc"      [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)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid" 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 Doc AnsiStyle
"realloc" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"invocation: 2 arguments expected"
        Calloc Text
"mem_alloc"    [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)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid" 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 Doc AnsiStyle
"mem_alloc" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"invocation: 1 argument after" 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 Doc AnsiStyle
"mem" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"expected"
        Calloc Text
"mem_valloc"   [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)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid" 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 Doc AnsiStyle
"mem_valloc" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"invocation: 2 arguments after" 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 Doc AnsiStyle
"mem" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"expected"
        Calloc Text
"mem_vrealloc" [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)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"invalid" 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 Doc AnsiStyle
"mem_vrealloc" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"invocation: 3 argument after" 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 Doc AnsiStyle
"mem" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"expected"

        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-args", [Text] -> Text
Text.unlines
    [ Text
"Checks that `mem_alloc`, `mem_valloc`, and `mem_vrealloc` are used correctly:"
    , Text
""
    , Text
"- The `size` argument (e.g. for `mem_alloc`, the second argument) should be a"
    , Text
"  pure `sizeof` expression without additions or multiplications."
    , Text
"- There should be no `sizeof` in the `nmemb` argument of a memory allocation"
    , Text
"  call."
    , Text
""
    , Text
"**Reason:** we want to avoid arbitrary computations in allocation sizes to"
    , Text
"ensure the allocation size is exactly correct for the type of the object"
    , Text
"being allocated."
    ]))