{-# 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 (CimplePos, Diagnostic)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              doNodes, traverseAst)
import           Prettyprinter               (pretty, (<+>))
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common             (backticks, warn, warnDoc, (>+>))


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 [Diagnostic CimplePos]) Text
lintAssign :: AstActions (State [Diagnostic CimplePos]) Text
lintAssign = 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
        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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos] ()
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)
-> 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
"allocations using" 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
name)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"must first be assigned to a local variable or "
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"returned directly"

        Node (Lexeme Text)
_ -> State [Diagnostic CimplePos] ()
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 [Diagnostic CimplePos]) Text
lintCheck :: AstActions (State [Diagnostic CimplePos]) Text
lintCheck = AstActions (State [Diagnostic CimplePos]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNodes :: FilePath
-> [Node (Lexeme Text)]
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
doNodes = \FilePath
file [Node (Lexeme Text)]
nodes State [Diagnostic CimplePos] ()
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 [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
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 [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
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)
-> 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)
s (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 (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
decl) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", assigned from" 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
name)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"must immediately be checked against `nullptr`"

        [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
lintCheck ((FilePath, [Node (Lexeme Text)])
 -> State [Diagnostic CimplePos] ())
-> ((FilePath, [Node (Lexeme Text)])
    -> State [Diagnostic CimplePos] ())
-> (FilePath, [Node (Lexeme Text)])
-> State [Diagnostic CimplePos] ()
forall (m :: * -> *) t.
Monad m =>
(t -> m ()) -> (t -> m ()) -> t -> m ()
>+> 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
lintAssign)
    -- TODO(iphydf): Refactor after the toxav PR.
    ((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/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)]) -> [Diagnostic CimplePos], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos],
 (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
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."
    ]))