{-# 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 (CimplePos, Diagnostic,
                                              DiagnosticsT)
import           Language.Cimple.Pretty      (ppNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty, (<+>))
import           Tokstyle.Common             (backticks, warn, warnDoc)


checkAssertArg :: FilePath -> Lexeme Text -> Node (Lexeme Text) -> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg :: FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
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{}     -> () -> DiagnosticsT [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SizeofExpr{}      -> () -> DiagnosticsT [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SizeofType{}      -> () -> DiagnosticsT [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      VarExpr{}         -> () -> DiagnosticsT [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
e      -> FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      ParenExpr Node (Lexeme Text)
e       -> FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      MemberAccess Node (Lexeme Text)
e Lexeme Text
_  -> FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
      UnaryExpr UnaryOp
_ Node (Lexeme Text)
e     -> FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
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)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
e
          FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
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)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
lhs
          FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
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)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
cond
          FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
thenB
          FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
elseB
      FunctionCall Node (Lexeme Text)
_ [] -> () -> DiagnosticsT [Diagnostic CimplePos] ()
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) -> DiagnosticsT [Diagnostic CimplePos] ())
-> [Node (Lexeme Text)] -> DiagnosticsT [Diagnostic CimplePos] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath
-> Lexeme Text
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name) [Node (Lexeme Text)]
args
          Bool
-> DiagnosticsT [Diagnostic CimplePos] ()
-> DiagnosticsT [Diagnostic CimplePos] ()
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) (DiagnosticsT [Diagnostic CimplePos] ()
 -> DiagnosticsT [Diagnostic CimplePos] ())
-> DiagnosticsT [Diagnostic CimplePos] ()
-> DiagnosticsT [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
              FilePath
-> Lexeme Text
-> Doc AnsiStyle
-> DiagnosticsT [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
name (Doc AnsiStyle -> DiagnosticsT [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> DiagnosticsT [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
                  Doc AnsiStyle
"non-pure function" 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 (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
func) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"cannot be called inside `assert()`"
      NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> FilePath
-> Lexeme Text
-> Doc AnsiStyle
-> DiagnosticsT [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Lexeme Text
name (Doc AnsiStyle -> DiagnosticsT [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> DiagnosticsT [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle
"invalid expression in assert: `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
expr Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` 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 [Diagnostic CimplePos]) Text
linter :: AstActions (State [Diagnostic CimplePos]) Text
linter = AstActions (State [Diagnostic CimplePos]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text)
-> DiagnosticsT [Diagnostic CimplePos] ()
-> DiagnosticsT [Diagnostic CimplePos] ()
doNode = \FilePath
file Node (Lexeme Text)
node DiagnosticsT [Diagnostic CimplePos] ()
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)
-> DiagnosticsT [Diagnostic CimplePos] ()
checkAssertArg FilePath
file Lexeme Text
name Node (Lexeme Text)
arg

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> DiagnosticsT [Diagnostic CimplePos] ()
act
    }


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
. (DiagnosticsT [Diagnostic CimplePos] ()
 -> [Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos]
-> DiagnosticsT [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> b -> a -> c
flip DiagnosticsT [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState [] (DiagnosticsT [Diagnostic CimplePos] () -> [Diagnostic CimplePos])
-> ((FilePath, [Node (Lexeme Text)])
    -> DiagnosticsT [Diagnostic CimplePos] ())
-> (FilePath, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Diagnostic CimplePos]) Text
-> (FilePath, [Node (Lexeme Text)])
-> DiagnosticsT [Diagnostic CimplePos] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Diagnostic CimplePos]) 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
"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."
    ]))