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

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 (..), lexemeLine,
                                              lexemeText)
import           Language.Cimple.Diagnostics (HasDiagnostics (..), warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)


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

empty :: Linter
empty :: Linter
empty = [Text] -> [(Text, (Lexeme Text, Scope))] -> 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
            FunctionDecl Scope
declScope (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, Scope))]
decls :: [(Text, (Lexeme Text, Scope))]
decls :: Linter -> [(Text, (Lexeme Text, Scope))]
decls} -> Linter
l{decls :: [(Text, (Lexeme Text, Scope))]
decls = (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name, (Lexeme Text
name, Scope
declScope)) (Text, (Lexeme Text, Scope))
-> [(Text, (Lexeme Text, Scope))] -> [(Text, (Lexeme Text, Scope))]
forall a. a -> [a] -> [a]
: [(Text, (Lexeme Text, Scope))]
decls}
            FunctionDefn Scope
defnScope (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ -> do
                Linter{[(Text, (Lexeme Text, Scope))]
decls :: [(Text, (Lexeme Text, Scope))]
decls :: Linter -> [(Text, (Lexeme Text, Scope))]
decls} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                case Text
-> [(Text, (Lexeme Text, Scope))] -> Maybe (Lexeme Text, Scope)
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, Scope))]
decls of
                    Maybe (Lexeme Text, Scope)
Nothing -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just (Lexeme Text
decl, Scope
declScope) ->
                        Bool -> State Linter () -> State Linter ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Scope
declScope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
/= Scope
defnScope) (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
$
                            Lexeme Text -> Scope -> Scope -> Text
warning Lexeme Text
decl Scope
declScope Scope
defnScope

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
act
    }
  where
    warning :: Lexeme Text -> Scope -> Scope -> Text
warning Lexeme Text
decl Scope
declScope Scope
defnScope =
        Text
"function definition `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
decl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` does not agree with its declaration about scope: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"declaration on line " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Lexeme Text -> Int
forall text. Lexeme text -> Int
lexemeLine Lexeme Text
decl))
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Scope -> Text
forall p. IsString p => Scope -> p
scopeKeyword Scope
declScope Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but definition is "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Scope -> Text
forall p. IsString p => Scope -> p
scopeKeyword Scope
defnScope

    scopeKeyword :: Scope -> p
scopeKeyword Scope
Global = p
"extern"
    scopeKeyword Scope
Static = p
"static"

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
. 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

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"func-scopes", [Text] -> Text
Text.unlines
    [ Text
"Checks that static function definitions are marked with `static`."
    , Text
""
    , Text
"In C, a function is `static` even if the definition doesn't use `static`, but"
    , Text
"there happens to be another declaration of the function which does."
    , Text
""
    , Text
"**Reason:** static/extern qualification of functions should be visible locally."
    , Text
"It takes mental effort otherwise to look up the declaration to check for storage"
    , Text
"qualifiers."
    ]))