{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.BooleanReturn (descr) where

import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..), foldFix)
import qualified Data.List                   as List
import qualified Data.Maybe                  as Maybe
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), LiteralType (..),
                                              Node, NodeF (..), UnaryOp (..),
                                              lexemeText)
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty, (<+>))
import           Tokstyle.Common             (backticks, warn, warnDoc)


data Value a
    = Const a
    | NonConst
    | Returned (Value a)
    deriving (Int -> Value a -> ShowS
[Value a] -> ShowS
Value a -> String
(Int -> Value a -> ShowS)
-> (Value a -> String) -> ([Value a] -> ShowS) -> Show (Value a)
forall a. Show a => Int -> Value a -> ShowS
forall a. Show a => [Value a] -> ShowS
forall a. Show a => Value a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value a] -> ShowS
$cshowList :: forall a. Show a => [Value a] -> ShowS
show :: Value a -> String
$cshow :: forall a. Show a => Value a -> String
showsPrec :: Int -> Value a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Value a -> ShowS
Show, a -> Value b -> Value a
(a -> b) -> Value a -> Value b
(forall a b. (a -> b) -> Value a -> Value b)
-> (forall a b. a -> Value b -> Value a) -> Functor Value
forall a b. a -> Value b -> Value a
forall a b. (a -> b) -> Value a -> Value b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Value b -> Value a
$c<$ :: forall a b. a -> Value b -> Value a
fmap :: (a -> b) -> Value a -> Value b
$cfmap :: forall a b. (a -> b) -> Value a -> Value b
Functor)

emptyIfAnyNonConst :: [Value a] -> [Value a]
emptyIfAnyNonConst :: [Value a] -> [Value a]
emptyIfAnyNonConst [Value a]
values =
    if (Value a -> Bool) -> [Value a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value a -> Bool
forall a. Value a -> Bool
isNonConst [Value a]
values then [] else [Value a]
values
  where
    isNonConst :: Value a -> Bool
isNonConst (Returned Value a
NonConst) = Bool
True
    isNonConst Value a
_                   = Bool
False

returnedConstValues :: Node (Lexeme Text) -> [Text]
returnedConstValues :: Node (Lexeme Text) -> [Text]
returnedConstValues = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
List.sort ([Text] -> [Text])
-> (Node (Lexeme Text) -> [Text]) -> Node (Lexeme Text) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Eq a => [a] -> [a]
List.nub ([Text] -> [Text])
-> (Node (Lexeme Text) -> [Text]) -> Node (Lexeme Text) -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value Text -> Maybe Text) -> [Value Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Value Text -> Maybe Text
forall a. Value a -> Maybe a
returnedConst ([Value Text] -> [Text])
-> (Node (Lexeme Text) -> [Value Text])
-> Node (Lexeme Text)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value Text] -> [Value Text]
forall a. [Value a] -> [Value a]
emptyIfAnyNonConst ([Value Text] -> [Value Text])
-> (Node (Lexeme Text) -> [Value Text])
-> Node (Lexeme Text)
-> [Value Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeF (Lexeme Text) [Value Text] -> [Value Text])
-> Node (Lexeme Text) -> [Value Text]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme Text) [Value Text] -> [Value Text]
forall a.
(Semigroup a, IsString a) =>
NodeF (Lexeme a) [Value a] -> [Value a]
go
  where
    go :: NodeF (Lexeme a) [Value a] -> [Value a]
go (LiteralExpr LiteralType
Int (L AlexPosn
_ LexemeClass
_ a
value)) = [a -> Value a
forall a. a -> Value a
Const a
value]
    go (Return (Just [Value a]
value))           = (Value a -> Value a) -> [Value a] -> [Value a]
forall a b. (a -> b) -> [a] -> [b]
map Value a -> Value a
forall a. Value a -> Value a
Returned [Value a]
value
    go (UnaryExpr UnaryOp
op [Value a]
e)                = (Value a -> Value a) -> [Value a] -> [Value a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> Value a -> Value a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnaryOp -> a
forall p. IsString p => UnaryOp -> p
uopToken UnaryOp
op a -> a -> a
forall a. Semigroup a => a -> a -> a
<>)) [Value a]
e

    go NodeF (Lexeme a) [Value a]
n                               = (Value a -> Value a) -> [Value a] -> [Value a]
forall a b. (a -> b) -> [a] -> [b]
map Value a -> Value a
forall a. Value a -> Value a
toNonConst ([Value a] -> [Value a]) -> [Value a] -> [Value a]
forall a b. (a -> b) -> a -> b
$ ([Value a] -> [Value a] -> [Value a])
-> [Value a] -> NodeF (Lexeme a) [Value a] -> [Value a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Value a] -> [Value a] -> [Value a]
forall a. [a] -> [a] -> [a]
(++) [Value a
forall a. Value a
NonConst] NodeF (Lexeme a) [Value a]
n

    returnedConst :: Value a -> Maybe a
returnedConst (Returned (Const a
value)) = a -> Maybe a
forall a. a -> Maybe a
Just a
value
    returnedConst Value a
_                        = Maybe a
forall a. Maybe a
Nothing

    toNonConst :: Value a -> Value a
toNonConst Const{} = Value a
forall a. Value a
NonConst
    toNonConst Value a
v       = Value a
v

    uopToken :: UnaryOp -> p
uopToken UnaryOp
UopMinus = p
"-"
    uopToken UnaryOp
op       = String -> p
forall a. HasCallStack => String -> a
error (UnaryOp -> String
forall a. Show a => a -> String
show UnaryOp
op)


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 :: String
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
doNode = \String
file Node (Lexeme Text)
node State [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
            FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
name [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ | Lexeme Text -> Bool
isEligible Lexeme Text
name ->
                case Node (Lexeme Text) -> [Text]
returnedConstValues Node (Lexeme Text)
node of
                  [Text
v1, Text
v2] -> String
-> Lexeme Text -> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
String -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc String
file Lexeme Text
name (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
                      Doc AnsiStyle
"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 (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"only ever returns two values"
                      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
v1) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"and" 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
v2) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"; it can return `bool`"
                  [Text]
_ -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State [Diagnostic CimplePos] ()
act
    }
  where
    -- Ignore event handlers named something with "handle" in the name.
    isEligible :: Lexeme Text -> Bool
isEligible = Bool -> Bool
not (Bool -> Bool) -> (Lexeme Text -> Bool) -> Lexeme Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"handle" Text -> Text -> Bool
`Text.isInfixOf`) (Text -> Bool) -> (Lexeme Text -> Text) -> Lexeme Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
analyse :: (String, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
analyse = [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> ((String, [Node (Lexeme Text)]) -> [Diagnostic CimplePos])
-> (String, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [Diagnostic CimplePos] ()
 -> [Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> [Diagnostic CimplePos]
-> State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Diagnostic CimplePos] ()
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall s a. State s a -> s -> s
State.execState [] (State [Diagnostic CimplePos] () -> [Diagnostic CimplePos])
-> ((String, [Node (Lexeme Text)])
    -> State [Diagnostic CimplePos] ())
-> (String, [Node (Lexeme Text)])
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Diagnostic CimplePos]) Text
-> (String, [Node (Lexeme Text)])
-> State [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 :: ((String, [Node (Lexeme Text)]) -> [Diagnostic CimplePos],
 (Text, Text))
descr = ((String, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
analyse, (Text
"boolean-return", [Text] -> Text
Text.unlines
    [ Text
"Checks for functions that always return constant integers and thus seem to be"
    , Text
"semantically boolean functions. E.g. a function returning -1 for error and 0 for"
    , Text
"success should rather return `false` for error and `true` for success and change"
    , Text
"its return type to `bool`."
    , Text
""
    , Text
"**Reason:** boolean returns using `bool` (or an `enum` type) are clearer than"
    , Text
"ones returning an `int` that happens to only have 2 possible values."
    ]))