{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE ViewPatterns      #-}
module Tokstyle.Linter.NonNull (descr) where

import           Control.Arrow               ((&&&))
--import           Control.Monad               (when)
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.Pretty      (showNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
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}

indices :: [Lexeme Text] -> [(Int, Lexeme Text)]
indices :: [Lexeme Text] -> [(Int, Lexeme Text)]
indices = (Lexeme Text -> (Int, Lexeme Text))
-> [Lexeme Text] -> [(Int, Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (Lexeme Text -> String) -> Lexeme Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Lexeme Text -> Text) -> Lexeme Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText (Lexeme Text -> Int)
-> (Lexeme Text -> Lexeme Text)
-> Lexeme Text
-> (Int, Lexeme Text)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Lexeme Text -> Lexeme Text
forall a. a -> a
id)

paramMap :: [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
paramMap :: [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
paramMap = ((Int, Node (Lexeme Text)) -> Bool)
-> [(Int, Node (Lexeme Text))] -> [(Int, Node (Lexeme Text))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node (Lexeme Text) -> Bool
isPointer (Node (Lexeme Text) -> Bool)
-> ((Int, Node (Lexeme Text)) -> Node (Lexeme Text))
-> (Int, Node (Lexeme Text))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Node (Lexeme Text)) -> Node (Lexeme Text)
forall a b. (a, b) -> b
snd) ([(Int, Node (Lexeme Text))] -> [(Int, Node (Lexeme Text))])
-> ([Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))])
-> [Node (Lexeme Text)]
-> [(Int, Node (Lexeme Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]

checkParams :: FilePath -> [Lexeme Text] -> [Lexeme Text] -> [Node (Lexeme Text)] -> State Linter ()
checkParams :: String
-> [Lexeme Text]
-> [Lexeme Text]
-> [Node (Lexeme Text)]
-> State Linter ()
checkParams String
_ [] [] [Node (Lexeme Text)]
_ = () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- non_null() marks all params as non-null
checkParams String
file ([Lexeme Text] -> [(Int, Lexeme Text)]
indices -> [(Int, Lexeme Text)]
nonnull) ([Lexeme Text] -> [(Int, Lexeme Text)]
indices -> [(Int, Lexeme Text)]
nullable) [Node (Lexeme Text)]
params = do
    case [(Int, Node (Lexeme Text))] -> [(Int, Node (Lexeme Text))]
forall b. [(Int, b)] -> [(Int, b)]
unmarked [(Int, Node (Lexeme Text))]
ptrParams of
        [] -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Int
ix, Node (Lexeme Text)
l):[(Int, Node (Lexeme Text))]
_ -> String -> Node (Lexeme Text) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Node (Lexeme Text)
l (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"pointer-type parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
ix) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`) has no non_null or nullable attribute"
    case [(Int, Lexeme Text)] -> [(Int, Lexeme Text)]
forall b. [(Int, b)] -> [(Int, b)]
superfluous [(Int, Lexeme Text)]
nullable of
        [] -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Int
ix, Lexeme Text
l):[(Int, Lexeme Text)]
_ -> String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
l (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"parameter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
showParam Int
ix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") does not have a pointer type; nullability has no effect"
  where
    ptrParams :: [(Int, Node (Lexeme Text))]
ptrParams = [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
paramMap [Node (Lexeme Text)]
params
    unmarked :: [(Int, b)] -> [(Int, b)]
unmarked = ((Int, b) -> Bool) -> [(Int, b)] -> [(Int, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Int, b) -> Bool) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Int, Lexeme Text) -> Int) -> [(Int, Lexeme Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Lexeme Text) -> Int
forall a b. (a, b) -> a
fst [(Int, Lexeme Text)]
nonnull [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ ((Int, Lexeme Text) -> Int) -> [(Int, Lexeme Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Lexeme Text) -> Int
forall a b. (a, b) -> a
fst [(Int, Lexeme Text)]
nullable) (Int -> Bool) -> ((Int, b) -> Int) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst)
    superfluous :: [(Int, b)] -> [(Int, b)]
superfluous = ((Int, b) -> Bool) -> [(Int, b)] -> [(Int, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Int, b) -> Bool) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Int, Node (Lexeme Text)) -> Int)
-> [(Int, Node (Lexeme Text))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Node (Lexeme Text)) -> Int
forall a b. (a, b) -> a
fst [(Int, Node (Lexeme Text))]
ptrParams) (Int -> Bool) -> ((Int, b) -> Int) -> (Int, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst)

    showParam :: Int -> Text
    showParam :: Int -> Text
showParam Int
ix =
        case Int -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. Int -> [a] -> [a]
drop (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Node (Lexeme Text)]
params of
          [] -> Text
"only " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([Node (Lexeme Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node (Lexeme Text)]
params)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" parameters available"
          Node (Lexeme Text)
p:[Node (Lexeme Text)]
_ -> Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"


isDestructor :: Lexeme Text -> Bool
isDestructor :: Lexeme Text -> Bool
isDestructor Lexeme Text
name =
    Text
"_free" Text -> Text -> Bool
`Text.isSuffixOf` Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name Bool -> Bool -> Bool
||
    Text
"_kill" Text -> Text -> Bool
`Text.isSuffixOf` Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name Bool -> Bool -> Bool
||
    Text
"kill_" Text -> Text -> Bool
`Text.isPrefixOf` Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name


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 :: String -> Node (Lexeme Text) -> State Linter () -> State Linter ()
doNode = \String
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
            FunctionDecl Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) ->
                (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}

            NonNull [Lexeme Text]
_ [] (Fix (FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)
_])))) | Lexeme Text -> Bool
isDestructor Lexeme Text
name ->
                String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
name (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"destructor function `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` must accept nullable arguments"

            NonNull [Lexeme Text]
nonnull [Lexeme Text]
nullable (Fix (FunctionDefn Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
params)) Node (Lexeme Text)
_)) -> do
                String
-> [Lexeme Text]
-> [Lexeme Text]
-> [Node (Lexeme Text)]
-> State Linter ()
checkParams String
file [Lexeme Text]
nonnull [Lexeme Text]
nullable [Node (Lexeme Text)]
params
                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
                    Maybe (Lexeme Text)
Nothing -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just Lexeme Text
prev -> do
                       String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
name Text
"static function must have nullability attribute on its declaration if it has one"
                       String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
prev Text
"  declaration was here"

            NonNull [Lexeme Text]
_ [Lexeme Text]
_ (Fix (FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
params)) Node (Lexeme Text)
_)) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (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)]
params ->
               String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
name Text
"function definition has no pointer-type parameters, nullability has no effect"
            NonNull [Lexeme Text]
_ [Lexeme Text]
_ (Fix (FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
params)))) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (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)]
params ->
               String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
name Text
"function declaration has no pointer-type parameters, nullability has no effect"

            NonNull [Lexeme Text]
_ [Lexeme Text]
_ (Fix (FunctionDefn Scope
Global (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_)) ->
               String -> Lexeme Text -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
name Text
"global function must only have nullability attribute on its declaration, not on its definition"

            NonNull [Lexeme Text]
nonnull [Lexeme Text]
nullable (Fix (FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
_ [Node (Lexeme Text)]
params)))) ->
                String
-> [Lexeme Text]
-> [Lexeme Text]
-> [Node (Lexeme Text)]
-> State Linter ()
checkParams String
file [Lexeme Text]
nonnull [Lexeme Text]
nullable [Node (Lexeme Text)]
params

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
act
    }

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse :: (String, [Node (Lexeme Text)]) -> [Text]
analyse = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ((String, [Node (Lexeme Text)]) -> [Text])
-> (String, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> [Text]
diags (Linter -> [Text])
-> ((String, [Node (Lexeme Text)]) -> Linter)
-> (String, [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)
-> ((String, [Node (Lexeme Text)]) -> State Linter ())
-> (String, [Node (Lexeme Text)])
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State Linter) Text
-> (String, [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

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr :: ((String, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((String, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"non-null", [Text] -> Text
Text.unlines
    [ Text
"Checks that all pointer parameters are listed in either `non_null` or"
    , Text
"`nullable`, and that none of the numbers in these annotations are non-pointers."
    , Text
""
    , Text
"**Reason:** see `-Wmissing-non-null` for more context. This check ensures that"
    , Text
"nullability annotations are updated when parameter lists change."
    ]))