{-# 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 :: Linter -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
diags} = Linter
l{diags = diag : diags}


linter :: AstActions (State Linter) Text
linter :: AstActions (StateT Linter Identity) Text
linter = AstActions (StateT Linter Identity) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode = \FilePath
file Node (Lexeme Text)
node StateT Linter Identity ()
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) -> StateT Linter Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Linter -> Linter) -> StateT Linter Identity ())
-> (Linter -> Linter) -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$ \l :: Linter
l@Linter{[(Text, (Lexeme Text, Scope))]
decls :: Linter -> [(Text, (Lexeme Text, Scope))]
decls :: [(Text, (Lexeme Text, Scope))]
decls} -> Linter
l{decls = (lexemeText name, (name, declScope)) : 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 :: Linter -> [(Text, (Lexeme Text, Scope))]
decls :: [(Text, (Lexeme Text, Scope))]
decls} <- StateT Linter Identity 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 -> () -> StateT Linter Identity ()
forall a. a -> StateT Linter Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just (Lexeme Text
decl, Scope
declScope) ->
                        Bool -> StateT Linter Identity () -> StateT Linter Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Scope
declScope Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
/= Scope
defnScope) (StateT Linter Identity () -> StateT Linter Identity ())
-> StateT Linter Identity () -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> Lexeme Text -> Doc AnsiStyle -> StateT Linter Identity ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
name (Doc AnsiStyle -> StateT Linter Identity ())
-> Doc AnsiStyle -> StateT Linter Identity ()
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))
_ -> StateT Linter Identity ()
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 ann. Text -> Doc ann
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 ann. Int -> Doc ann
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 ann. Text -> Doc ann
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 ann. Text -> Doc ann
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
. (StateT Linter Identity () -> Linter -> Linter)
-> Linter -> StateT Linter Identity () -> Linter
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Linter Identity () -> Linter -> Linter
forall s a. State s a -> s -> s
State.execState Linter
empty (StateT Linter Identity () -> Linter)
-> ((FilePath, [Node (Lexeme Text)]) -> StateT Linter Identity ())
-> (FilePath, [Node (Lexeme Text)])
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (StateT Linter Identity) Text
-> (FilePath, [Node (Lexeme Text)]) -> StateT Linter Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT Linter Identity) 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."
    ]))