{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.Assert (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.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), Node, NodeF (..))
import           Language.Cimple.Diagnostics (Diagnostics)
import qualified Language.Cimple.Diagnostics as Diagnostics
import           Language.Cimple.Pretty      (showNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)


checkAssertArg :: FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg :: FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
expr =
    case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
expr of
      LiteralExpr{}     -> () -> Diagnostics ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SizeofExpr{}      -> () -> Diagnostics ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SizeofType{}      -> () -> Diagnostics ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      VarExpr{}         -> () -> Diagnostics ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
e      -> FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      ParenExpr Node (Lexeme Text)
e       -> FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      MemberAccess Node (Lexeme Text)
e Lexeme Text
_  -> FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      UnaryExpr UnaryOp
_ Node (Lexeme Text)
e     -> FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      ArrayAccess Node (Lexeme Text)
e Node (Lexeme Text)
i   -> do
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
i
      BinaryExpr Node (Lexeme Text)
lhs BinaryOp
_ Node (Lexeme Text)
rhs -> do
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
lhs
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
rhs
      TernaryExpr Node (Lexeme Text)
cond Node (Lexeme Text)
thenB Node (Lexeme Text)
elseB -> do
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
cond
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
thenB
          FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
elseB
      FunctionCall Node (Lexeme Text)
_ [] -> () -> Diagnostics ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- no arguments = constant function
      FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
func))) [Node (Lexeme Text)]
args -> do
          (Node (Lexeme Text) -> Diagnostics ())
-> [Node (Lexeme Text)] -> Diagnostics ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name) [Node (Lexeme Text)]
args
          Bool -> Diagnostics () -> Diagnostics ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
func Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
exemptions) (Diagnostics () -> Diagnostics ())
-> Diagnostics () -> Diagnostics ()
forall a b. (a -> b) -> a -> b
$
              FilePath -> Lexeme Text -> Text -> Diagnostics ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
Diagnostics.warn FilePath
file Lexeme Text
name (Text -> Diagnostics ()) -> Text -> Diagnostics ()
forall a b. (a -> b) -> a -> b
$
                  Text
"non-pure function `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
func Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` cannot be called inside `assert()`"
      NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> FilePath -> Lexeme Text -> Text -> Diagnostics ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
Diagnostics.warn FilePath
file Lexeme Text
name (Text -> Diagnostics ()) -> Text -> Diagnostics ()
forall a b. (a -> b) -> a -> b
$
          Text
"invalid expression in assert: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
expr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not a pure function"

-- Known const/pure functions.
exemptions :: [Text]
exemptions :: [Text]
exemptions =
    [ Text
"make_family"
    , Text
"memcmp"
    , Text
"shared_key_is_empty"
    , Text
"tox_events_get_size"
    ]


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 :: FilePath -> Node (Lexeme Text) -> Diagnostics () -> Diagnostics ()
doNode = \FilePath
file Node (Lexeme Text)
node Diagnostics ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionCall (Fix (VarExpr name :: Lexeme Text
name@(L AlexPosn
_ LexemeClass
_ Text
"assert"))) [Node (Lexeme Text)
arg] ->
                FilePath -> Lexeme Text -> Node (Lexeme Text) -> Diagnostics ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
arg

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Diagnostics ()
act
    }


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
. (Diagnostics () -> [Text] -> [Text])
-> [Text] -> Diagnostics () -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Diagnostics () -> [Text] -> [Text]
forall s a. State s a -> s -> s
State.execState [] (Diagnostics () -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> Diagnostics ())
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Text]) Text
-> (FilePath, [Node (Lexeme Text)]) -> Diagnostics ()
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 :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"assert", [Text] -> Text
Text.unlines
    [ Text
"Checks whether `assert` is side-effect-free. Only pure expressions"
    , Text
"(no function calls, no assignments) and an allowlist of exemptions are permitted"
    , Text
"within `assert`. The current list of exemptions is:"
    , Text
""
    , Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
exemptions
    , Text
""
    , Text
"**Reason:** `assert` is compiled out in `NDEBUG` builds, so should not influence"
    , Text
"logic of the code in debug modes to avoid different behaviours in different"
    , Text
"compilation modes."
    ]))