{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 (CimplePos, Diagnostic,
                                              HasDiagnosticsRich (..))
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty, (<+>))
import           Text.Casing                 (fromHumps, fromSnake, toPascal,
                                              toSnake, unIdentifier)
import           Text.Read                   (readMaybe)
import           Tokstyle.Common             (backticks, warn, warnDoc)


-- | 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 -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
    , Linter -> [Text]
defs  :: [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] -> Linter
Linter [] []

addDef :: Text -> Linter -> Linter
addDef :: Text -> Linter -> Linter
addDef Text
def l :: Linter
l@Linter{[Text]
defs :: Linter -> [Text]
defs :: [Text]
defs} = Linter
l{defs = def:defs}

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

commonPrefix :: [String] -> String
commonPrefix :: [FilePath] -> FilePath
commonPrefix [] = FilePath
""
commonPrefix (FilePath
first:[FilePath]
rest) = (FilePath -> FilePath -> FilePath)
-> FilePath -> [FilePath] -> FilePath
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FilePath -> FilePath -> FilePath
forall {a}. Eq a => [a] -> [a] -> [a]
go FilePath
first [FilePath]
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 :: FilePath -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs FilePath
file Node (Lexeme Text)
node = do
    Linter{[Text]
defs :: Linter -> [Text]
defs :: [Text]
defs} <- StateT Linter Identity Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
    let cp :: FilePath
cp = [FilePath] -> FilePath
commonPrefix ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
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 a. [a] -> 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
&& FilePath -> Int
numComponents FilePath
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
$
        FilePath -> Node (Lexeme Text) -> Doc AnsiStyle -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> State Linter ())
-> Doc AnsiStyle -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"sequence of `#define`s longer than" 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 Int
minSequence
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"could be written as" 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 (Doc AnsiStyle
"enum" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Text
toEnumName FilePath
cp))

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


isSmallInt :: Text -> Bool
isSmallInt :: Text -> Bool
isSmallInt Text
txt =
    case FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Int) -> FilePath -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
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 (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 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
                FilePath -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs FilePath
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.
                FilePath -> Node (Lexeme Text) -> State Linter ()
checkEnumDefs FilePath
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)]) -> [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
. (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 (StateT Linter Identity) Text
-> (FilePath, [Node (Lexeme Text)]) -> State Linter ()
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-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
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
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
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
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
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
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 (FilePath -> Text
Text.pack (FilePath -> Text)
-> ((Char, Int) -> FilePath) -> (Char, Int) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate Int
3 (Char -> FilePath)
-> ((Char, Int) -> Char) -> (Char, Int) -> FilePath
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
. FilePath -> [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]