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

import           Control.Applicative         ((<|>))
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..), foldFix)
import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map
import qualified Data.Maybe                  as Maybe
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), Node, NodeF (..),
                                              UnaryOp (..), lexemeText)
import           Language.Cimple.Diagnostics (warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)

-- | Specifies what is happening to a variable.
--
-- This enum has a total order of importance for combine and later filter.
--
-- Anything >=Write is good. Anything <=Read is bad.
data Action
    = Declare
      -- ^ The variable is never read or written. We don't warn about this
      -- because other linters already do.
    | Read
      -- ^ The variable is read. If it was locally declared and only read, then
      -- it was not declared const and should be.
    | Write
      -- ^ The variable is written to (and isn't const), so we don't warn about
      -- it.
    | Const
      -- ^ The variable is declared const, so everything is as we want it.
    deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show, Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq, Eq Action
Eq Action
-> (Action -> Action -> Ordering)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Action)
-> (Action -> Action -> Action)
-> Ord Action
Action -> Action -> Bool
Action -> Action -> Ordering
Action -> Action -> Action
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Action -> Action -> Action
$cmin :: Action -> Action -> Action
max :: Action -> Action -> Action
$cmax :: Action -> Action -> Action
>= :: Action -> Action -> Bool
$c>= :: Action -> Action -> Bool
> :: Action -> Action -> Bool
$c> :: Action -> Action -> Bool
<= :: Action -> Action -> Bool
$c<= :: Action -> Action -> Bool
< :: Action -> Action -> Bool
$c< :: Action -> Action -> Bool
compare :: Action -> Action -> Ordering
$ccompare :: Action -> Action -> Ordering
$cp1Ord :: Eq Action
Ord)

-- | Variable declaration and usage.
--
-- If varDecl is empty, the variable wasn't locally declared so we ignore it.
data Var = Var
    { Var -> Action
varUse  :: Action
    , Var -> Maybe (Lexeme Text)
varDecl :: Maybe (Lexeme Text)
    }
    deriving (Int -> Var -> ShowS
[Var] -> ShowS
Var -> String
(Int -> Var -> ShowS)
-> (Var -> String) -> ([Var] -> ShowS) -> Show Var
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Var] -> ShowS
$cshowList :: [Var] -> ShowS
show :: Var -> String
$cshow :: Var -> String
showsPrec :: Int -> Var -> ShowS
$cshowsPrec :: Int -> Var -> ShowS
Show, Var -> Var -> Bool
(Var -> Var -> Bool) -> (Var -> Var -> Bool) -> Eq Var
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Var -> Var -> Bool
$c/= :: Var -> Var -> Bool
== :: Var -> Var -> Bool
$c== :: Var -> Var -> Bool
Eq)

combine :: Var -> Var -> Var
combine :: Var -> Var -> Var
combine Var
var1 Var
var2 | Var
var1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
var2 = Var
var1
combine (Var Action
use1 Maybe (Lexeme Text)
decl1) (Var Action
use2 Maybe (Lexeme Text)
decl2) =
    Action -> Maybe (Lexeme Text) -> Var
Var (Action -> Action -> Action
forall a. Ord a => a -> a -> a
max Action
use1 Action
use2) (Maybe (Lexeme Text)
decl1 Maybe (Lexeme Text) -> Maybe (Lexeme Text) -> Maybe (Lexeme Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Lexeme Text)
decl2)

readToWrite :: Var -> Var
readToWrite :: Var -> Var
readToWrite Var
var = Var
var{varUse :: Action
varUse = Action
Write}


constness :: NodeF (Lexeme Text) (Map Text Var) -> Map Text Var
constness :: NodeF (Lexeme Text) (Map Text Var) -> Map Text Var
constness = \case
    -- Only vardecls without array dimensions are added to the list. Arrays are
    -- considered not locally declared, so they are ignored.
    VarDecl Map Text Var
t l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) [] ->
        let var :: Var
var = Var -> Maybe Var -> Var
forall a. a -> Maybe a -> a
Maybe.fromMaybe (Action -> Maybe (Lexeme Text) -> Var
Var Action
Declare Maybe (Lexeme Text)
forall a. Maybe a
Nothing) (Maybe Var -> Var) -> Maybe Var -> Var
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Var -> Maybe Var
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"" Map Text Var
t in
        Text -> Var -> Map Text Var
forall k a. k -> a -> Map k a
Map.singleton Text
name Var
var{varDecl :: Maybe (Lexeme Text)
varDecl = Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l}

    VarExpr (L AlexPosn
_ LexemeClass
_ Text
name)    -> Text -> Map Text Var
forall k. k -> Map k Var
readDecl Text
name

    -- If it was declared const, we're good.
    -- We left-union with vars which may contain a fake-write created below for
    -- pointers and `va_list`.
    TyConst Map Text Var
vars            -> Map Text Var -> Map Text Var -> Map Text Var
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Var
vars Map Text Var
constDecl
    -- Ignore `va_list` (by faking a write to pointer vars).
    TyStd (L AlexPosn
_ LexemeClass
_ Text
"va_list") -> Map Text Var
writeDecl
    -- Ignore pointers for now.
    TyPointer{}             -> Map Text Var
writeDecl

    -- The array index isn't written to, so remove it from the list unless it
    -- was already written to elsewhere.
    ArrayAccess Map Text Var
e Map Text Var
i         -> (Var -> Var -> Var) -> Map Text Var -> Map Text Var -> Map Text Var
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Var -> Var -> Var
combine Map Text Var
e ((Var -> Bool) -> Map Text Var -> Map Text Var
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Action -> Action -> Bool
forall a. Ord a => a -> a -> Bool
>= Action
Write) (Action -> Bool) -> (Var -> Action) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Action
varUse) Map Text Var
i)

    -- Ignore function parameters for now.
    FunctionPrototype{}     -> Map Text Var
forall k a. Map k a
Map.empty

    -- These expressions (potentially) write to vars.
    AssignExpr Map Text Var
lhs AssignOp
_ Map Text Var
rhs ->
        (Var -> Var -> Var) -> Map Text Var -> Map Text Var -> Map Text Var
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Var -> Var -> Var
combine Map Text Var
rhs
        (Map Text Var -> Map Text Var) -> Map Text Var -> Map Text Var
forall a b. (a -> b) -> a -> b
$ (Var -> Var) -> Map Text Var -> Map Text Var
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Var -> Var
readToWrite Map Text Var
lhs
    UnaryExpr UnaryOp
uop Map Text Var
expr | UnaryOp -> Bool
canWrite UnaryOp
uop ->
        (Var -> Var) -> Map Text Var -> Map Text Var
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Var -> Var
readToWrite Map Text Var
expr

    NodeF (Lexeme Text) (Map Text Var)
n -> (Var -> Var -> Var)
-> NodeF (Lexeme Text) (Map Text Var) -> Map Text Var
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Var -> Var -> Var
combine NodeF (Lexeme Text) (Map Text Var)
n
  where
    readDecl :: k -> Map k Var
readDecl = (k -> Var -> Map k Var) -> Var -> k -> Map k Var
forall a b c. (a -> b -> c) -> b -> a -> c
flip k -> Var -> Map k Var
forall k a. k -> a -> Map k a
Map.singleton (Action -> Maybe (Lexeme Text) -> Var
Var Action
Read Maybe (Lexeme Text)
forall a. Maybe a
Nothing)
    constDecl :: Map Text Var
constDecl = Text -> Var -> Map Text Var
forall k a. k -> a -> Map k a
Map.singleton Text
"" (Action -> Maybe (Lexeme Text) -> Var
Var Action
Const Maybe (Lexeme Text)
forall a. Maybe a
Nothing)
    writeDecl :: Map Text Var
writeDecl = Text -> Var -> Map Text Var
forall k a. k -> a -> Map k a
Map.singleton Text
"" (Action -> Maybe (Lexeme Text) -> Var
Var Action
Write Maybe (Lexeme Text)
forall a. Maybe a
Nothing)

    canWrite :: UnaryOp -> Bool
canWrite UnaryOp
UopAddress = Bool
True
    canWrite UnaryOp
UopDecr    = Bool
True
    canWrite UnaryOp
UopIncr    = Bool
True
    canWrite UnaryOp
_          = Bool
False


findCandidatesForConst :: Node (Lexeme Text) -> [Lexeme Text]
findCandidatesForConst :: Node (Lexeme Text) -> [Lexeme Text]
findCandidatesForConst =
    (Var -> Maybe (Lexeme Text)) -> [Var] -> [Lexeme Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Var -> Maybe (Lexeme Text)
varDecl
    ([Var] -> [Lexeme Text])
-> (Node (Lexeme Text) -> [Var])
-> Node (Lexeme Text)
-> [Lexeme Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Action -> Action -> Bool
forall a. Ord a => a -> a -> Bool
<= Action
Read) (Action -> Bool) -> (Var -> Action) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Action
varUse)
    ([Var] -> [Var])
-> (Node (Lexeme Text) -> [Var]) -> Node (Lexeme Text) -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Var -> [Var]
forall k a. Map k a -> [a]
Map.elems
    (Map Text Var -> [Var])
-> (Node (Lexeme Text) -> Map Text Var)
-> Node (Lexeme Text)
-> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeF (Lexeme Text) (Map Text Var) -> Map Text Var)
-> Node (Lexeme Text) -> Map Text Var
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme Text) (Map Text Var) -> Map Text Var
constness


linter :: AstActions (State [Text]) Text
linter :: AstActions (State [Text]) Text
linter = AstActions (State [Text]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: String -> Node (Lexeme Text) -> State [Text] () -> State [Text] ()
doNode = \String
file Node (Lexeme Text)
node State [Text] ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionDefn{} ->
                let vars :: [Lexeme Text]
vars = Node (Lexeme Text) -> [Lexeme Text]
findCandidatesForConst Node (Lexeme Text)
node in
                (Lexeme Text -> State [Text] ())
-> [Lexeme Text] -> State [Text] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Lexeme Text
var -> String -> Lexeme Text -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
var (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
                    Text
"variable `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
var
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is never written to and can be declared `const`") [Lexeme Text]
vars

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State [Text] ()
act
    }

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
. (State [Text] () -> [Text] -> [Text])
-> [Text] -> State [Text] () -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Text] () -> [Text] -> [Text]
forall s a. State s a -> s -> s
State.execState [] (State [Text] () -> [Text])
-> ((String, [Node (Lexeme Text)]) -> State [Text] ())
-> (String, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Text]) Text
-> (String, [Node (Lexeme Text)]) -> State [Text] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Text]) 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
"constness", [Text] -> Text
Text.unlines
    [ Text
"Warns if a variable can be marked as `const`, i.e. it is only initialised and"
    , Text
"then never assigned again. Pointer types are exempt, i.e. `int *p = get_p();`"
    , Text
"is fine and doesn't need to be written as `int *const p = get_p();`, but"
    , Text
"`int q = get_q();`, if then `q` is never assigned again, should be written as"
    , Text
"`const int q = get_q();`."
    , Text
""
    , Text
"**Reason:** `const` makes the no-assign local invariant clear. We exempt pointer"
    , Text
"types at the moment, because making that change in toxcore would be a lot of"
    , Text
"work and we perceive less value in that than in local integer constants, since"
    , Text
"pointers, especially aggregate object pointers, already change less often."
    ]))