{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.MallocCall (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 (..))
import           Language.Cimple.Diagnostics (warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              doNodes, traverseAst)
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common             ((>+>))


mallocFuncs :: [Text]
mallocFuncs :: [Text]
mallocFuncs =
    [ Text
"mem_balloc"
    , Text
"mem_alloc"
    , Text
"mem_valloc"
    , Text
"mem_vrealloc"
    , Text
"malloc"
    , Text
"calloc"
    , Text
"realloc"
    ]

pattern FunCall, FunctionCast :: text -> Node (Lexeme text)
pattern $mFunCall :: forall r text.
Node (Lexeme text) -> (text -> r) -> (Void# -> r) -> r
FunCall      name <- Fix (FunctionCall (Fix (VarExpr (L _ _ name))) _)
pattern $mFunctionCast :: forall r text.
Node (Lexeme text) -> (text -> r) -> (Void# -> r) -> r
FunctionCast name <- Fix (CastExpr _ (FunCall name))

pattern MallocVarDecl :: text -> Node (Lexeme text) -> Node (Lexeme text)
pattern $mMallocVarDecl :: forall r text.
Node (Lexeme text)
-> (text -> Node (Lexeme text) -> r) -> (Void# -> r) -> r
MallocVarDecl decl initialiser <- Fix (VarDeclStmt (Fix (VarDecl _ (L _ _ decl) _)) (Just initialiser))

pattern MallocReturn :: Node lexeme -> Node lexeme
pattern $mMallocReturn :: forall r lexeme.
Node lexeme -> (Node lexeme -> r) -> (Void# -> r) -> r
MallocReturn initialiser <- Fix (Return (Just initialiser))

lintAssign :: AstActions (State [Text]) Text
lintAssign :: AstActions (State [Text]) Text
lintAssign = 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
        MallocVarDecl Text
_ (FunctionCast Text
name) | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        MallocReturn    (FunctionCast Text
name) | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- We check in -Wcalloc-type that casts are done correctly. This avoids
        -- double-warning on non-cast malloc calls.
        MallocVarDecl Text
_ (FunCall      Text
name) | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        MallocReturn    (FunCall      Text
name) | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        FunCall Text
name | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs ->
            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
"allocations using `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` must first be assigned to a local variable or "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"returned directly"

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

pattern NullCheck :: Text -> Node (Lexeme Text) -> Node (Lexeme Text)
pattern $mNullCheck :: forall r.
Node (Lexeme Text)
-> (Text -> Node (Lexeme Text) -> r) -> (Void# -> r) -> r
NullCheck ref nullptr <-
    Fix (IfStmt
        (Fix (BinaryExpr (Fix (VarExpr (L _ _ ref))) _ nullptr))
        (Fix (CompoundStmt _)) _)
pattern ConstNull, VarNull :: Node (Lexeme Text)
pattern $mConstNull :: forall r. Node (Lexeme Text) -> (Void# -> r) -> (Void# -> r) -> r
ConstNull <- Fix (LiteralExpr _ (L _ _ "nullptr"))
pattern $mVarNull :: forall r. Node (Lexeme Text) -> (Void# -> r) -> (Void# -> r) -> r
VarNull <- Fix (VarExpr (L _ _ "nullptr"))

lintCheck :: AstActions (State [Text]) Text
lintCheck :: AstActions (State [Text]) Text
lintCheck = AstActions (State [Text]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNodes :: FilePath
-> [Node (Lexeme Text)] -> State [Text] () -> State [Text] ()
doNodes = \FilePath
file [Node (Lexeme Text)]
nodes State [Text] ()
act -> case [Node (Lexeme Text)]
nodes of
        (MallocVarDecl Text
decl FunctionCast{}:ss :: [Node (Lexeme Text)]
ss@(NullCheck Text
ref Node (Lexeme Text)
ConstNull:[Node (Lexeme Text)]
_)) | Text
decl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ref ->
            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
lintCheck (FilePath
file, [Node (Lexeme Text)]
ss)
        (MallocVarDecl Text
decl FunctionCast{}:ss :: [Node (Lexeme Text)]
ss@(NullCheck Text
ref Node (Lexeme Text)
VarNull:[Node (Lexeme Text)]
_)) | Text
decl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ref ->
            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
lintCheck (FilePath
file, [Node (Lexeme Text)]
ss)
        (MallocVarDecl Text
decl (FunctionCast Text
name):Node (Lexeme Text)
s:[Node (Lexeme Text)]
_) | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocFuncs ->
            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)
s (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
decl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`, assigned from `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` must immediately be checked against `nullptr`"

        [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
lintCheck ((FilePath, [Node (Lexeme Text)]) -> State [Text] ())
-> ((FilePath, [Node (Lexeme Text)]) -> State [Text] ())
-> (FilePath, [Node (Lexeme Text)])
-> State [Text] ()
forall (m :: * -> *) t.
Monad m =>
(t -> m ()) -> (t -> m ()) -> t -> m ()
>+> 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
lintAssign)
    -- TODO(iphydf): Refactor after the toxav PR.
    ((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/audio.c"
        , FilePath
"toxav/groupav.c"
        , FilePath
"toxav/msi.c"
        , FilePath
"toxav/ring_buffer.c"
        , FilePath
"toxav/rtp.c"
        , FilePath
"toxav/toxav.c"
        , FilePath
"toxav/video.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
"malloc-call", [Text] -> Text
Text.unlines
    [ Text
"Checks that allocation functions like `mem_balloc` are always first assigned to"
    , Text
"a local variable. The exception is in a return statement, e.g. in simple typed"
    , Text
"allocation functions like `logger_new()`. If the allocation is stored in a local"
    , Text
"variable, that variable must immediately be checked against `nullptr` before"
    , Text
"doing anything else."
    , Text
""
    , Text
"Invalid code:"
    , Text
""
    , Text
"```c"
    , Text
"ob->mem = (My_Struct *)mem_alloc(mem, sizeof(My_Struct));"
    , Text
"```"
    , Text
""
    , Text
"Valid code:"
    , Text
""
    , Text
"```c"
    , Text
"My_Struct *tmp = (My_Struct *)mem_alloc(mem, sizeof(My_Struct))"
    , Text
"if (tmp == nullptr) {"
    , Text
"  return false;"
    , Text
"}"
    , Text
"ob->mem = tmp;"
    , Text
"```"
    , Text
""
    , Text
"**Reason:** This avoids accidentally putting `nullptr` into a location without"
    , Text
"checking first. Putting `nullptr` somewhere may be ok, but we must do it"
    , Text
"intentionally."
    ]))