{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.C.Linter.CallbackParams (descr) where

import           Data.Functor.Identity           (Identity)
import           Data.Maybe                      (mapMaybe)
import           Data.Text                       (Text)
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemError    (invalidAST)
import           Language.C.Analysis.SemRep      (GlobalDecls, ParamDecl (..),
                                                  Type (..), VarDecl (..))
import           Language.C.Analysis.TravMonad   (Trav, TravT, throwTravError)
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST           (CExpr, CExpression (..),
                                                  annotation)
import           Prettyprinter                   (pretty, (<+>))
import           Tokstyle.C.Env                  (Env, recordLinterError)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)


paramNames :: (Int, ParamDecl, ParamDecl) -> Maybe (Int, String, String)
paramNames :: (Int, ParamDecl, ParamDecl) -> Maybe (Int, String, String)
paramNames (Int
i, ParamName String
a, ParamName String
b) | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
b = (Int, String, String) -> Maybe (Int, String, String)
forall a. a -> Maybe a
Just (Int
i, String
a, String
b)
paramNames (Int, ParamDecl, ParamDecl)
_                             = Maybe (Int, String, String)
forall a. Maybe a
Nothing

funPtrParams :: Type -> [ParamDecl]
funPtrParams :: Type -> [ParamDecl]
funPtrParams (FunPtrParams [ParamDecl]
params) = [ParamDecl]
params
funPtrParams Type
_                     = []

checkParams :: (ParamDecl, CExpr, Type) -> Trav Env ()
checkParams :: (ParamDecl, CExpr, Type) -> Trav Env ()
checkParams (ParamDecl (VarDecl VarName
_ DeclAttrs
_ cbTy :: Type
cbTy@(FunPtrParams [ParamDecl]
params)) NodeInfo
_, CExpr
expr, Type
ty) = do
    let cbParams :: [ParamDecl]
cbParams = Type -> [ParamDecl]
funPtrParams Type
ty
    case ((Int, ParamDecl, ParamDecl) -> Maybe (Int, String, String))
-> [(Int, ParamDecl, ParamDecl)] -> [(Int, String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, ParamDecl, ParamDecl) -> Maybe (Int, String, String)
paramNames ([(Int, ParamDecl, ParamDecl)] -> [(Int, String, String)])
-> [(Int, ParamDecl, ParamDecl)] -> [(Int, String, String)]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [ParamDecl] -> [ParamDecl] -> [(Int, ParamDecl, ParamDecl)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1..] [ParamDecl]
params [ParamDecl]
cbParams of
        [] -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Int
i, String
a, String
b):[(Int, String, String)]
_ ->
            NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
expr) (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
                Doc AnsiStyle
"parameter" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
i Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"of" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (CExpr -> Doc
forall p. Pretty p => p -> Doc
C.pretty CExpr
expr)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is named" 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 (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
b)
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", but in callback type" 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 (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
cbTy))) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"it is named" 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 (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
a)
checkParams (ParamDecl, CExpr, Type)
_ = () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doExpr :: CExpr -> Trav Env () -> Trav Env ()
doExpr = \CExpr
node Trav Env ()
act -> case CExpr
node of
        CCall CExpr
fun [CExpr]
args NodeInfo
_ ->
            [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
fun TravT Env Identity Type -> (Type -> Trav Env ()) -> Trav Env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                FunPtrParams [ParamDecl]
params -> do
                    [Type]
tys <- (CExpr -> TravT Env Identity Type)
-> [CExpr] -> TravT Env Identity [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue) [CExpr]
args
                    ((ParamDecl, CExpr, Type) -> Trav Env ())
-> [(ParamDecl, CExpr, Type)] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ParamDecl, CExpr, Type) -> Trav Env ()
checkParams ([ParamDecl] -> [CExpr] -> [Type] -> [(ParamDecl, CExpr, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ParamDecl]
params [CExpr]
args [Type]
tys)
                    Trav Env ()
act
                Type
x -> InvalidASTError -> Trav Env ()
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (InvalidASTError -> Trav Env ()) -> InvalidASTError -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> InvalidASTError
invalidAST (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
node) (String -> InvalidASTError) -> String -> InvalidASTError
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Show a => a -> String
show Type
x

        CExpr
_ -> Trav Env ()
act
    }


analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse = AstActions (TravT Env Identity) -> GlobalDecls -> Trav Env ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst AstActions (TravT Env Identity)
linter


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"callback-params", Text
"Checks that the parameter names of a callback match its definition."))