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

import           Control.Monad               (unless)
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.Maybe                  (maybeToList)
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), Node, NodeF (..))
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic,
                                              HasDiagnosticsRich (..))
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (hsep, pretty, punctuate, (<+>))
import           Tokstyle.Common             (backticks, warn, warnDoc)


data Linter = Linter
    { Linter -> [Diagnostic CimplePos]
diags    :: [Diagnostic CimplePos]
    , Linter -> Text
enumName :: Text
    , Linter -> Text
prefix   :: Text
    }

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}

empty :: Linter
empty :: Linter
empty = [Diagnostic CimplePos] -> Text -> Text -> Linter
Linter [] Text
"" Text
""

exemptions :: [Text]
exemptions :: [Text]
exemptions =
    [ Text
"Connection_Status"
    , Text
"Crypto_Conn_State"
    , Text
"Friend_Add_Error"
    , Text
"Friend_Status"
    , Text
"GC_Conn_State"
    , Text
"Group_Broadcast_Type"
    , Text
"Groupchat_Connection_Type"
    , Text
"Group_Exit_Type"
    , Text
"Group_Handshake_Join_Type"
    , Text
"Group_Handshake_Packet_Type"
    , Text
"Group_Handshake_Request_Type"
    , Text
"Group_Invite_Message_Type"
    , Text
"Group_Join_Rejected"
    , Text
"Group_Message_Ack_Type"
    , Text
"Group_Message_Id"
    , Text
"Group_Message_Type"
    , Text
"Group_Moderation_Event"
    , Text
"Group_Packet_Type"
    , Text
"Group_Peer_Status"
    , Text
"Group_Privacy_State"
    , Text
"Group_Role"
    , Text
"Group_Sync_Flags"
    , Text
"Group_Topic_Lock"
    , Text
"Group_Voice_State"
    , Text
"Invite_Id"
    , Text
"Mod_Sanction_Type"
    , Text
"MSICallbackID"
    , Text
"MSICallState"
    , Text
"MSICapabilities"
    , Text
"MSIError"
    , Text
"MSIHeaderID"
    , Text
"MSIRequest"
    , Text
"Net_Packet_Type"
    , Text
"Peer_Id"
    , Text
"RTPFlags"
    , Text
"Self_UDP_Status"
    , Text
"TCP_Client_Status"
    ]

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
            EnumConsts (Just (L AlexPosn
_ LexemeClass
_ Text
enumName)) [Node (Lexeme Text)]
_
                | Text
enumName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exemptions -> () -> StateT Linter Identity ()
forall a. a -> StateT Linter Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise -> do
                    let prefix :: Text
prefix = Text -> Text
Text.toUpper Text
enumName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
                    (Linter -> Linter)
-> StateT Linter Identity () -> StateT Linter Identity ()
forall s a. (s -> s) -> State s a -> State s a
State.withState (\Linter
s -> Linter
s{enumName, prefix}) StateT Linter Identity ()
act

            EnumDecl (L AlexPosn
_ LexemeClass
_ Text
enumName) [Node (Lexeme Text)]
_ Lexeme Text
_
                | Text
enumName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exemptions -> () -> StateT Linter Identity ()
forall a. a -> StateT Linter Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise -> do
                    let prefix :: Text
prefix = Text -> Text
Text.toUpper Text
enumName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_"
                    (Linter -> Linter)
-> StateT Linter Identity () -> StateT Linter Identity ()
forall s a. (s -> s) -> State s a -> State s a
State.withState (\Linter
s -> Linter
s{enumName, prefix}) StateT Linter Identity ()
act

            Enumerator (L AlexPosn
_ LexemeClass
_ Text
name) Maybe (Node (Lexeme Text))
_ -> do
                Linter{Text
enumName :: Linter -> Text
enumName :: Text
enumName, Text
prefix :: Linter -> Text
prefix :: Text
prefix} <- StateT Linter Identity Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                let prefixes :: [Text]
prefixes = Text -> [Text]
stripType Text
prefix
                Bool -> StateT Linter Identity () -> StateT Linter Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`Text.isPrefixOf` Text
name) [Text]
prefixes) (StateT Linter Identity () -> StateT Linter Identity ())
-> StateT Linter Identity () -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$
                    FilePath
-> Node (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 Node (Lexeme Text)
node (Doc AnsiStyle -> StateT Linter Identity ())
-> Doc AnsiStyle -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$
                        Doc AnsiStyle
"enumerator" 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 Text
name) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"in enum" 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 Text
enumName)
                        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"should start with"
                        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
hsep (Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc AnsiStyle
" or" ((Text -> Doc AnsiStyle) -> [Text] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (Doc AnsiStyle -> Doc AnsiStyle)
-> (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) [Text]
prefixes))

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> StateT Linter Identity ()
act
    }
  where
    stripType :: Text -> [Text]
    stripType :: Text -> [Text]
stripType Text
name =
        [Text
name]
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
allowSuffix Text
"_TYPE_"
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
allowSuffix Text
"_T_"
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
allowSuffix Text
"_E_"  -- for cmp
      where
        allowSuffix :: Text -> [Text]
allowSuffix Text
s = Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"_") (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripSuffix Text
s 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
. 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
"enum-names", [Text] -> Text
Text.unlines
    [ Text
"Checks that `enum` value constants have the same prefix as the `enum` type,"
    , Text
"except they should be SCREAMING_CASE instead of Camel_Snake. There are currently"
    , FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
exemptions) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exemptions to this rule. "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"New enums should follow the naming convention."
    , Text
""
    , Text
"**Reason:** this naming convention helps identify the type of an `enum` constant"
    , Text
"at first glance."
    ]))