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


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

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}

empty :: Linter
empty :: Linter
empty = [Text] -> 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 (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
            EnumConsts (Just (L AlexPosn
_ LexemeClass
_ Text
enumName)) [Node (Lexeme Text)]
_
                | Text
enumName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exemptions -> () -> State Linter ()
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) -> State Linter () -> State Linter ()
forall s a. (s -> s) -> State s a -> State s a
State.withState (\Linter
s -> Linter
s{Text
enumName :: Text
enumName :: Text
enumName, Text
prefix :: Text
prefix :: Text
prefix}) State Linter ()
act

            EnumDecl (L AlexPosn
_ LexemeClass
_ Text
enumName) [Node (Lexeme Text)]
_ Lexeme Text
_
                | Text
enumName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exemptions -> () -> State Linter ()
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) -> State Linter () -> State Linter ()
forall s a. (s -> s) -> State s a -> State s a
State.withState (\Linter
s -> Linter
s{Text
enumName :: Text
enumName :: Text
enumName, Text
prefix :: Text
prefix :: Text
prefix}) State Linter ()
act

            Enumerator (L AlexPosn
_ LexemeClass
_ Text
name) Maybe (Node (Lexeme Text))
_ -> do
                Linter{Text
enumName :: Text
enumName :: Linter -> Text
enumName, Text
prefix :: Text
prefix :: Linter -> Text
prefix} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                let prefixes :: [Text]
prefixes = Text -> [Text]
stripType Text
prefix
                Bool -> State Linter () -> State Linter ()
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) (State Linter () -> State Linter ())
-> State Linter () -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                    FilePath -> Node (Lexeme Text) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
node (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                        Text
"enumerator `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` in enum `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
enumName
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should start with "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
" or " ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
x -> Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`") [Text]
prefixes)

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
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)]) -> [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
"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 (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."
    ]))