{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.MissingNonNull (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 (..), lexemeText)
import           Language.Cimple.Diagnostics (HasDiagnostics (..), warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           System.FilePath             (takeFileName)
import           Tokstyle.Common             (isPointer)


data Linter = Linter
    { Linter -> [Text]
diags   :: [Text]
    , Linter -> [(Text, Lexeme Text)]
statics :: [(Text, Lexeme Text)]
    }

empty :: Linter
empty :: Linter
empty = [Text] -> [(Text, Lexeme Text)] -> Linter
Linter [] []

instance HasDiagnostics Linter where
    addDiagnostic :: Text -> Linter -> Linter
addDiagnostic Text
diag l :: Linter
l@Linter{[Text]
diags :: [Text]
diags :: Linter -> [Text]
diags} = Linter
l{diags :: [Text]
diags = Text -> [Text] -> [Text]
forall a. HasDiagnostics a => Text -> a -> a
addDiagnostic Text
diag [Text]
diags}


linter :: AstActions (State Linter) Text
linter :: AstActions (State Linter) Text
linter = AstActions (State Linter) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text) -> State Linter () -> State Linter ()
doNode = \FilePath
file Node (Lexeme Text)
node State Linter ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            NonNull [Lexeme Text]
_ [Lexeme Text]
_ (Fix (FunctionDecl Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)))) ->
                Lexeme Text -> State Linter ()
addStatic Lexeme Text
name
            NonNull [Lexeme Text]
_ [Lexeme Text]
_ (Fix (FunctionDefn Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_)) ->
                Lexeme Text -> State Linter ()
addStatic Lexeme Text
name

            NonNull{} -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            FunctionDecl Scope
Global (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
args)) | (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
isPointer [Node (Lexeme Text)]
args ->
               FilePath -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Lexeme Text
name Text
"global function has no non_null or nullable annotation"

            FunctionDefn Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
args)) Node (Lexeme Text)
_ | (Node (Lexeme Text) -> Bool) -> [Node (Lexeme Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node (Lexeme Text) -> Bool
isPointer [Node (Lexeme Text)]
args -> do
                Linter{[(Text, Lexeme Text)]
statics :: [(Text, Lexeme Text)]
statics :: Linter -> [(Text, Lexeme Text)]
statics} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                case Text -> [(Text, Lexeme Text)] -> Maybe (Lexeme Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name) [(Text, Lexeme Text)]
statics of
                    Just{}  -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe (Lexeme Text)
Nothing -> FilePath -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Lexeme Text
name Text
"static function must have nullability annotation"

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
act
    }
  where
    addStatic :: Lexeme Text -> State Linter ()
    addStatic :: Lexeme Text -> State Linter ()
addStatic Lexeme Text
name = (Linter -> Linter) -> State Linter ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Linter -> Linter) -> State Linter ())
-> (Linter -> Linter) -> State Linter ()
forall a b. (a -> b) -> a -> b
$ \l :: Linter
l@Linter{[(Text, Lexeme Text)]
statics :: [(Text, Lexeme Text)]
statics :: Linter -> [(Text, Lexeme Text)]
statics} -> Linter
l{statics :: [(Text, Lexeme Text)]
statics = (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name, Lexeme Text
name) (Text, Lexeme Text)
-> [(Text, Lexeme Text)] -> [(Text, Lexeme Text)]
forall a. a -> [a] -> [a]
: [(Text, Lexeme Text)]
statics}

exemptions :: [FilePath]
exemptions :: [FilePath]
exemptions =
    -- toxav is exempt for now, until we have the refactoring merged.
    [ FilePath
"audio.c"
    , FilePath
"audio.h"
    , FilePath
"bwcontroller.c"
    , FilePath
"bwcontroller.h"
    , FilePath
"groupav.c"
    , FilePath
"groupav.h"
    , FilePath
"msi.c"
    , FilePath
"msi.h"
    , FilePath
"ring_buffer.c"
    , FilePath
"ring_buffer.h"
    , FilePath
"rtp.c"
    , FilePath
"rtp.h"
    , FilePath
"toxav.c"
    , FilePath
"video.c"
    , FilePath
"video.h"

    -- public(ish) API headers are exempt.
    , FilePath
"tox.h"
    , FilePath
"tox_dispatch.h"
    , FilePath
"tox_events.h"
    , FilePath
"tox_options.h"
    , FilePath
"tox_private.h"
    , FilePath
"toxav.h"
    , FilePath
"toxencryptsave.h"

    -- cmp is exempt.
    , FilePath
"cmp.c"
    , FilePath
"cmp.h"
    ]

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse tu :: (FilePath, [Node (Lexeme Text)])
tu@(FilePath
path, [Node (Lexeme Text)]
_)
  | FilePath -> FilePath
takeFileName FilePath
path FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
exemptions = []
  | Bool
otherwise = [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
. Linter -> [Text]
diags (Linter -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> Linter)
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State Linter () -> Linter -> Linter)
-> Linter -> State Linter () -> Linter
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Linter () -> Linter -> Linter
forall s a. State s a -> s -> s
State.execState Linter
empty (State Linter () -> Linter)
-> ((FilePath, [Node (Lexeme Text)]) -> State Linter ())
-> (FilePath, [Node (Lexeme Text)])
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State Linter) Text
-> (FilePath, [Node (Lexeme Text)]) -> State Linter ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State Linter) Text
linter ((FilePath, [Node (Lexeme Text)]) -> [Text])
-> (FilePath, [Node (Lexeme Text)]) -> [Text]
forall a b. (a -> b) -> a -> b
$ (FilePath, [Node (Lexeme Text)])
tu

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"missing-non-null", [Text] -> Text
Text.unlines
    [ Text
"Checks that all function declarations have nullability annotations (`non_null`"
    , Text
"and/or `nullable`)."
    , Text
""
    , Text
"**Reason:** in TokTok code, we want to be explicit about which pointer"
    , Text
"parameters can be passed a NULL pointer. This forces the developer to think"
    , Text
"about nullability and allows static analysers to ensure that all possibly-NULL"
    , Text
"pointers are checked before being dereferenced or passed to a non-NULL parameter."
    ]))