{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.EnumDefines (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 (..), LiteralType (..),
                                              Node, NodeF (..))
import           Language.Cimple.Diagnostics (HasDiagnostics (..), warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Text.Casing                 (fromHumps, fromSnake, toPascal,
                                              toSnake, unIdentifier)
import           Text.Read                   (readMaybe)


-- | A sequence of #defines must be at least this long before we think it
-- should be an enum, instead.
minSequence :: Int
minSequence :: Int
minSequence = Int
5

-- | The common prefix must have at least this many components (e.g. FOO is
-- not a sufficient common prefix, but FOO_BAR is).
minComponents :: Int
minComponents :: Int
minComponents = Int
2

-- | We only enforce enums for small integers, so we skip floats and large
-- integers that might not fit into the underlying enum type (int). This also
-- skips sequences of `MAX_SOMETHING_...` that tend to be larger numbers.
maxSmallInt :: Int
maxSmallInt :: Int
maxSmallInt = Int
0xff

data Linter = Linter
    { Linter -> [Text]
diags :: [Text]
    , Linter -> [Text]
defs  :: [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] -> Linter
Linter [] []

addDef :: Text -> Linter -> Linter
addDef :: Text -> Linter -> Linter
addDef Text
def l :: Linter
l@Linter{[Text]
defs :: [Text]
defs :: Linter -> [Text]
defs} = Linter
l{defs :: [Text]
defs = Text
defText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
defs}

clearDefs :: Linter -> Linter
clearDefs :: Linter -> Linter
clearDefs Linter
l = Linter
l{defs :: [Text]
defs = []}

commonPrefix :: [String] -> String
commonPrefix :: [String] -> String
commonPrefix [] = String
""
commonPrefix (String
first:[String]
rest) = (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
go String
first [String]
rest
  where
    go :: [a] -> [a] -> [a]
go [a]
_ [] = []
    go [] [a]
_ = []
    go (a
x:[a]
xs) (a
y:[a]
ys)
      | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
xs [a]
ys
      | Bool
otherwise = []


checkEnumDefs :: FilePath -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs :: String -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs String
file Node (Lexeme Text)
node = do
    Linter{[Text]
defs :: [Text]
defs :: Linter -> [Text]
defs} <- StateT Linter Identity Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
    let cp :: String
cp = [String] -> String
commonPrefix ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack [Text]
defs
    -- Warn exactly once (hence == instead of >=).
    Bool -> State Linter () -> State Linter ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
defs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
minSequence Bool -> Bool -> Bool
&& String -> Int
numComponents String
cp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minComponents) (State Linter () -> State Linter ())
-> State Linter () -> State Linter ()
forall a b. (a -> b) -> a -> b
$
        String -> Node (Lexeme Text) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Node (Lexeme Text)
node (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"sequence of `#define`s longer than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
minSequence)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" could be written as `enum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
toEnumName String
cp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"

  where
    numComponents :: String -> Int
numComponents = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> (String -> [String]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> [String]
forall a. Identifier a -> [a]
unIdentifier (Identifier String -> [String])
-> (String -> Identifier String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromSnake
    toEnumName :: String -> Text
toEnumName = String -> Text
Text.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toSnake (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromHumps (String -> Identifier String)
-> (String -> String) -> String -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toPascal (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromSnake


isSmallInt :: Text -> Bool
isSmallInt :: Text -> Bool
isSmallInt Text
txt =
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
txt of
        Maybe Int
Nothing  -> Bool
False
        Just Int
num -> Int
num Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxSmallInt


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 :: String -> Node (Lexeme Text) -> State Linter () -> State Linter ()
doNode = \String
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
            PreprocDefineConst (L AlexPosn
_ LexemeClass
_ Text
name) (Fix (LiteralExpr LiteralType
Int (L AlexPosn
_ LexemeClass
_ Text
num))) | Text -> Bool
isSmallInt Text
num -> do
                (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
$ Text -> Linter -> Linter
addDef Text
name
                String -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs String
file Node (Lexeme Text)
node

            -- Skip comments, don't clear defs.
            Comment{} -> State Linter ()
act

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> do
                State Linter ()
act  -- Recurse first, check defs later.
                String -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs String
file Node (Lexeme Text)
node
                -- Clear defs whenever we see a new kind of node (not comment or #define).
                (Linter -> Linter) -> State Linter ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify Linter -> Linter
clearDefs
    }

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse :: (String, [Node (Lexeme Text)]) -> [Text]
analyse = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ((String, [Node (Lexeme Text)]) -> [Text])
-> (String, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> [Text]
diags (Linter -> [Text])
-> ((String, [Node (Lexeme Text)]) -> Linter)
-> (String, [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)
-> ((String, [Node (Lexeme Text)]) -> State Linter ())
-> (String, [Node (Lexeme Text)])
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State Linter) Text
-> (String, [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 :: ((String, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((String, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"enum-defines", [Text] -> Text
Text.unlines
    [ Text
"Suggests using `enum` instead of a sequence of `#define`s for enumerations."
    , Text
"Only matches sequences of `#define`s longer than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
minSequence)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to avoid some false positives."
    , Text
"Also, the sequence must have a common prefix of at least " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
minComponents)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" components. I.e."
    , Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
mkPrefix Int
1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not a sufficient common prefix, but `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
mkPrefix Int
0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is."
    , Text
"Lastly, we only require enums for small-int enums, i.e. all enumerators have a"
    , Text
"constant int expression value less than or equal to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
maxSmallInt) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    , Text
""
    , Text
"**Reason:** `enum` constants are safer, and can potentially be type-checked"
    , Text
"more thoroughly."
    ]))
  where
    mkPrefix :: Int -> Text
mkPrefix Int
n =
        Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text] -> Text) -> ([Int] -> [Text]) -> [Int] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, Int) -> Text) -> [(Char, Int)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text) -> ((Char, Int) -> String) -> (Char, Int) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
3 (Char -> String) -> ((Char, Int) -> Char) -> (Char, Int) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Int) -> Char
forall a b. (a, b) -> a
fst) ([(Char, Int)] -> [Text])
-> ([Int] -> [(Char, Int)]) -> [Int] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Int] -> [(Char, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char
'A'..] ([Int] -> Text) -> [Int] -> Text
forall a b. (a -> b) -> a -> b
$ [Int
1..Int
minComponentsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n]