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

import           Control.Monad               (unless, when)
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import qualified Data.List                   as List
import           Data.Set                    (Set)
import qualified Data.Set                    as Set
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)


data Linter = Linter
    { Linter -> [Text]
diags :: [Text]
    , Linter -> Set Text
decls :: Set Text
    }

empty :: Linter
empty :: Linter
empty = [Text] -> Set Text -> Linter
Linter [] Set Text
forall a. Set a
Set.empty

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}


findQualifiers :: Node (Lexeme Text) -> [Text]
findQualifiers :: Node (Lexeme Text) -> [Text]
findQualifiers (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    TyOwner Node (Lexeme Text)
t    -> Text
"_Owner" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
t
    TyNonnull Node (Lexeme Text)
t  -> Text
"_Nonnull" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
t
    TyNullable Node (Lexeme Text)
t -> Text
"_Nullable" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
t
    TyConst Node (Lexeme Text)
t    -> Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
t
    TyPointer Node (Lexeme Text)
t  -> Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
t
    NodeF (Lexeme Text) (Node (Lexeme Text))
_            -> []

findPrototypeQualifiers :: Node (Lexeme Text) -> [Text]
findPrototypeQualifiers :: Node (Lexeme Text) -> [Text]
findPrototypeQualifiers (Fix (FunctionPrototype Node (Lexeme Text)
retType Lexeme Text
_ [Node (Lexeme Text)]
params)) =
    Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
retType [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Node (Lexeme Text) -> [Text]) -> [Node (Lexeme Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Text]
findParamQualifiers [Node (Lexeme Text)]
params
  where
    findParamQualifiers :: Node (Lexeme Text) -> [Text]
findParamQualifiers (Fix (VarDecl Node (Lexeme Text)
ty Lexeme Text
_ [Node (Lexeme Text)]
_)) = Node (Lexeme Text) -> [Text]
findQualifiers Node (Lexeme Text)
ty
    findParamQualifiers Node (Lexeme Text)
_                      = []
findPrototypeQualifiers Node (Lexeme Text)
_ = []


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
            FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) -> do
                (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
$ \Linter
s -> Linter
s { decls :: Set Text
decls = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name) (Linter -> Set Text
decls Linter
s) }
                State Linter ()
act

            FunctionDefn Scope
scope proto :: Node (Lexeme Text)
proto@(Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ -> do
                Linter{Set Text
decls :: Set Text
decls :: Linter -> Set Text
decls} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                let nameText :: Text
nameText = Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name
                let isDeclared :: Bool
isDeclared = Text
nameText Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
decls
                let qs :: [Text]
qs = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
List.nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> [Text]
findPrototypeQualifiers Node (Lexeme Text)
proto
                Bool -> State Linter () -> State Linter ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
qs Bool -> Bool -> Bool
|| (Scope
scope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
Static Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDeclared)) (State Linter () -> State Linter ())
-> State Linter () -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                    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 -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"qualifier" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
qs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Text
"s" else Text
"")
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
" and " ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
q -> Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`") [Text]
qs)
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" should only be used on function declarations, not definitions"
                State Linter ()
act

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


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

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr = ([(FilePath, [Node (Lexeme Text)])] -> [Text]
analyse, (Text
"ownership-decls", [Text] -> Text
Text.unlines
    [ Text
"Checks that `_Owner`, `_Nullable`, and `_Nonnull` are only set on declarations,"
    , Text
"not definitions, unless it's a static definition without prior declaration."
    , Text
""
    , Text
"**Reason:** keeping qualifiers on declarations only reduces clutter in the"
    , Text
"implementation and ensures that the interface is the single source of truth"
    , Text
"for ownership or nullability information."
    ]))