{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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   (CimplePos, Diagnostic,
                                                HasDiagnosticsRich (..))
import           Language.Cimple.TraverseAst   (AstActions, astActions, doNode,
                                                traverseAst)
import           Prettyprinter                 (Doc, pretty, (<+>))
import           Prettyprinter.Render.Terminal (AnsiStyle)
import           Tokstyle.Common               (backticks, warn, warnDoc)


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

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

instance HasDiagnosticsRich Linter CimplePos where
    addDiagnosticRich :: Diagnostic CimplePos -> Linter -> Linter
addDiagnosticRich Diagnostic CimplePos
diag l :: Linter
l@Linter{[Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
diags :: Linter -> [Diagnostic CimplePos]
diags} = Linter
l{diags :: [Diagnostic CimplePos]
diags = Diagnostic CimplePos
diag Diagnostic CimplePos
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. a -> [a] -> [a]
: [Diagnostic CimplePos]
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 -> Doc AnsiStyle -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
name (Doc AnsiStyle -> State Linter ())
-> Doc AnsiStyle -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                            Lexeme Text -> Scope -> Scope -> Doc AnsiStyle
warning Lexeme Text
decl Scope
declScope Scope
defnScope

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
act
    }
  where
    warning :: Lexeme Text -> Scope -> Scope -> Doc AnsiStyle
    warning :: Lexeme Text -> Scope -> Scope -> Doc AnsiStyle
warning Lexeme Text
decl Scope
declScope Scope
defnScope =
        Doc AnsiStyle
"function definition" 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 (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
decl))
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"does not agree with its declaration about scope: "
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"declaration on line" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Lexeme Text -> Int
forall text. Lexeme text -> Int
lexemeLine Lexeme Text
decl)
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is" 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 (Scope -> Text
scopeKeyword Scope
declScope)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"but definition is"
        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 (Scope -> Text
scopeKeyword Scope
defnScope))

    scopeKeyword :: Scope -> Text
    scopeKeyword :: Scope -> Text
scopeKeyword Scope
Global = Text
"extern"
    scopeKeyword Scope
Static = Text
"static"
    scopeKeyword Scope
Local  = Text
"local"

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
. Linter -> [Diagnostic CimplePos]
diags (Linter -> [Diagnostic CimplePos])
-> ((FilePath, [Node (Lexeme Text)]) -> Linter)
-> (FilePath, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
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)]) -> [Diagnostic CimplePos], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos],
 (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
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."
    ]))