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

import           Control.Applicative           ((<|>))
import           Control.Monad.State.Strict    (State)
import qualified Control.Monad.State.Strict    as State
import           Data.Fix                      (Fix (..))
import           Data.Maybe                    (fromMaybe)
import           Data.Text                     (Text)
import qualified Data.Text                     as Text
import           Language.Cimple               (Lexeme (..), Node, NodeF (..),
                                                lexemeText)
import           Language.Cimple.Diagnostics   (CimplePos, Diagnostic)
import           Language.Cimple.TraverseAst   (AstActions, astActions, doNode,
                                                traverseAst)
import           Prettyprinter                 (Doc, pretty, (<+>))
import           Prettyprinter.Render.Terminal (AnsiStyle)
import           Tokstyle.Common               (backticks, warn, warnDoc)

valid :: Lexeme Text -> Lexeme Text -> Bool
valid :: Lexeme Text -> Lexeme Text -> Bool
valid (L AlexPosn
_ LexemeClass
_ Text
tname) (L AlexPosn
_ LexemeClass
_ Text
sname) =
    Text
sname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tname Bool -> Bool -> Bool
|| Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (do
        Text
t <- Text -> Text -> Maybe Text
Text.stripSuffix Text
"_t" Text
tname
        Text
s <- Text -> Text -> Maybe Text
Text.stripSuffix Text
"_s" Text
sname Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Text -> Maybe Text
Text.stripSuffix Text
"_u" Text
sname Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Text -> Maybe Text
Text.stripSuffix Text
"_e" Text
sname
        Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s)

linter :: AstActions (State [Diagnostic CimplePos]) Text
linter :: AstActions (State [Diagnostic CimplePos]) Text
linter = AstActions (State [Diagnostic CimplePos]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
doNode = \FilePath
file Node (Lexeme Text)
node State [Diagnostic CimplePos] ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            Typedef (Fix (TyStruct Lexeme Text
sname)) Lexeme Text
tname [Node (Lexeme Text)]
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Lexeme Text -> Bool
valid Lexeme Text
tname Lexeme Text
sname ->
                FilePath
-> Lexeme Text -> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
sname (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
warning Text
"struct" Lexeme Text
tname Lexeme Text
sname
            Typedef (Fix (Struct Lexeme Text
sname [Node (Lexeme Text)]
_)) Lexeme Text
tname [Node (Lexeme Text)]
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Lexeme Text -> Bool
valid Lexeme Text
tname Lexeme Text
sname ->
                FilePath
-> Lexeme Text -> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
sname (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
warning Text
"struct" Lexeme Text
tname Lexeme Text
sname
            Typedef (Fix (Union Lexeme Text
uname [Node (Lexeme Text)]
_)) Lexeme Text
tname [Node (Lexeme Text)]
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Lexeme Text -> Bool
valid Lexeme Text
tname Lexeme Text
uname ->
                FilePath
-> Lexeme Text -> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
uname (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
warning Text
"union" Lexeme Text
tname Lexeme Text
uname
            EnumDecl Lexeme Text
ename [Node (Lexeme Text)]
_ Lexeme Text
tname | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Lexeme Text -> Bool
valid Lexeme Text
tname Lexeme Text
ename ->
                FilePath
-> Lexeme Text -> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
ename (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
warning Text
"enum" Lexeme Text
tname Lexeme Text
ename

            FunctionDefn{} -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State [Diagnostic CimplePos] ()
act
    }
  where
    warning :: Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
    warning :: Text -> Lexeme Text -> Lexeme Text -> Doc AnsiStyle
warning Text
tag Lexeme Text
tname Lexeme Text
name =
        Doc AnsiStyle
"typedef name" 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
tname)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"does not match" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"name" 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
name))

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
. (State [Diagnostic CimplePos] ()
 -> [Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos]
-> State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState [] (State [Diagnostic CimplePos] () -> [Diagnostic CimplePos])
-> ((FilePath, [Node (Lexeme Text)])
    -> State [Diagnostic CimplePos] ())
-> (FilePath, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Diagnostic CimplePos]) Text
-> (FilePath, [Node (Lexeme Text)])
-> State [Diagnostic CimplePos] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Diagnostic CimplePos]) 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
"typedef-name", [Text] -> Text
Text.unlines
    [ Text
"Checks that typedef names match the struct/union name. E.g."
    , Text
"`typedef struct Foo_ { ... } Foo;` should instead be"
    , Text
"`typedef struct Foo { ... } Foo;`."
    , Text
""
    , Text
"**Reason:** there is no good reason for them to be different, and it adds"
    , Text
"confusion and a potential for C++ code to pick the wrong name and later break"
    , Text
"in refactorings."
    ]))