{-# 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 (warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common.Patterns


checkSize, checkNmemb :: Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
checkSize :: Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [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)
size (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`size` argument in call to `" 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 a sizeof expression"

checkNmemb :: Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    VarExpr{}         -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ParenExpr Node (Lexeme Text)
e       -> Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
e
    PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
l
        Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
r

    SizeofType{} ->
        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)
nmemb (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`sizeof` should not appear in the `nmemb` argument to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

    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)
nmemb (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"invalid expression in `nmemb` argument to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funName 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)

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
        Calloc funName :: Text
funName@Text
"calloc" [Node (Lexeme Text)
nmemb, Node (Lexeme Text)
size] -> do
            Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
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 [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
checkNmemb Text
funName FilePath
file Node (Lexeme Text)
nmemb
            Text -> FilePath -> Node (Lexeme Text) -> State [Text] ()
checkSize Text
funName FilePath
file Node (Lexeme Text)
size

        Calloc Text
"calloc"       [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)
node Text
"invalid `calloc` invocation: 2 arguments expected"
        Calloc Text
"realloc"      [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)
node Text
"invalid `realloc` invocation: 2 arguments expected"
        Calloc Text
"mem_alloc"    [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)
node Text
"invalid `mem_alloc` invocation: 1 argument after `mem` expected"
        Calloc Text
"mem_valloc"   [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)
node Text
"invalid `mem_valloc` invocation: 2 arguments after `mem` expected"
        Calloc Text
"mem_vrealloc" [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)
node Text
"invalid `mem_vrealloc` invocation: 3 argument after `mem` 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 [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-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."
    ]))