{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE ViewPatterns      #-}
module Tokstyle.C.Linter.CallbackData (descr) where

import           Control.Monad                   (forM_, when)
import           Data.Functor.Identity           (Identity)
import           Data.List                       (isSuffixOf)
import           Data.Map.Strict                 (Map)
import qualified Data.Map.Strict                 as Map
import           Data.Maybe                      (listToMaybe, mapMaybe)
import           Data.Text                       (Text)
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemRep      (FunDef (..), FunType (..),
                                                  GlobalDecls (..),
                                                  IdentDecl (..),
                                                  ParamDecl (..), Type (..),
                                                  TypeQuals (..), VarDecl (..),
                                                  VarName (..), noTypeQuals)
import           Language.C.Analysis.TravMonad   (Trav, TravT, getUserState,
                                                  modifyUserState)
import           Language.C.Analysis.TypeUtils   (canonicalType, sameType)
import           Language.C.Data.Ident           (Ident (Ident))
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST
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)


-- | Get the name of an identifier.
idName :: Ident -> String
idName :: Ident -> String
idName (Ident String
name Int
_ NodeInfo
_) = String
name


-- | Strip qualifiers from a type.
stripQualifiers :: Type -> Type
stripQualifiers :: Type -> Type
stripQualifiers = \case
    DirectType TypeName
ty TypeQuals
_ Attributes
attrs    -> TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
ty TypeQuals
noTypeQuals Attributes
attrs
    PtrType Type
ty TypeQuals
_ Attributes
attrs       -> Type -> TypeQuals -> Attributes -> Type
PtrType (Type -> Type
stripQualifiers Type
ty) TypeQuals
noTypeQuals Attributes
attrs
    ArrayType Type
ty ArraySize
sz TypeQuals
_ Attributes
attrs  -> Type -> ArraySize -> TypeQuals -> Attributes -> Type
ArrayType (Type -> Type
stripQualifiers Type
ty) ArraySize
sz TypeQuals
noTypeQuals Attributes
attrs
    FunctionType FunType
ty Attributes
attrs    -> FunType -> Attributes -> Type
FunctionType FunType
ty Attributes
attrs
    TypeDefType TypeDefRef
tdr TypeQuals
_ Attributes
attrs  -> TypeDefRef -> TypeQuals -> Attributes -> Type
TypeDefType TypeDefRef
tdr TypeQuals
noTypeQuals Attributes
attrs

-- | Check if two types are compatible context types.
-- T* is compatible with T* and void*.
compatibleContext :: Type -> Type -> Bool
compatibleContext :: Type -> Type -> Bool
compatibleContext (Type -> Type
canonicalType -> Type
TY_void_ptr) Type
_ = Bool
True
compatibleContext Type
_ (Type -> Type
canonicalType -> Type
TY_void_ptr) = Bool
True
compatibleContext Type
a Type
b = Type -> Type -> Bool
compatible (Type -> Type
canonicalType Type
a) (Type -> Type
canonicalType Type
b)
  where
    compatible :: Type -> Type -> Bool
compatible (PtrType Type
aTy TypeQuals
_ Attributes
_) (PtrType Type
bTy TypeQuals
_ Attributes
_) = Type -> Type -> Bool
compatible Type
aTy Type
bTy
    compatible Type
a' Type
b' = Type -> Type -> Bool
sameType (Type -> Type
stripQualifiers Type
a') (Type -> Type
stripQualifiers Type
b')


-- | Check if a type is a function pointer or a function.
isFunPtr :: Type -> Bool
isFunPtr :: Type -> Bool
isFunPtr (Type -> Type
canonicalType -> PtrType FunctionType{} TypeQuals
_ Attributes
_) = Bool
True
isFunPtr (Type -> Type
canonicalType -> FunctionType{})             = Bool
True
isFunPtr Type
_                                             = Bool
False


-- | Check if a type is a void pointer.
isVoidPtr :: Type -> Bool
isVoidPtr :: Type -> Bool
isVoidPtr (Type -> Type
canonicalType -> Type
TY_void_ptr) = Bool
True
isVoidPtr Type
_                              = Bool
False


-- | Get the type of a parameter.
getParamType :: ParamDecl -> Type
getParamType :: ParamDecl -> Type
getParamType (ParamDecl (VarDecl VarName
_ DeclAttrs
_ Type
ty) NodeInfo
_)         = Type
ty
getParamType (AbstractParamDecl (VarDecl VarName
_ DeclAttrs
_ Type
ty) NodeInfo
_) = Type
ty


-- | Find the first function pointer and first void pointer in a list of arguments.
findCallbackPair :: [(ParamDecl, CExpr, Type)] -> Maybe (CExpr, Type, CExpr, Type)
findCallbackPair :: [(ParamDecl, CExpr, Type)] -> Maybe (CExpr, Type, CExpr, Type)
findCallbackPair [(ParamDecl, CExpr, Type)]
args =
    let funPtrs :: [(ParamDecl, CExpr, Type)]
funPtrs = ((ParamDecl, CExpr, Type) -> Bool)
-> [(ParamDecl, CExpr, Type)] -> [(ParamDecl, CExpr, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ParamDecl
p, CExpr
_, Type
_) -> Type -> Bool
isFunPtr (ParamDecl -> Type
getParamType ParamDecl
p)) [(ParamDecl, CExpr, Type)]
args
        voidPtrs :: [(ParamDecl, CExpr, Type)]
voidPtrs = ((ParamDecl, CExpr, Type) -> Bool)
-> [(ParamDecl, CExpr, Type)] -> [(ParamDecl, CExpr, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ParamDecl
p, CExpr
_, Type
_) -> Type -> Bool
isVoidPtr (ParamDecl -> Type
getParamType ParamDecl
p)) [(ParamDecl, CExpr, Type)]
args
    in case ([(ParamDecl, CExpr, Type)]
funPtrs, [(ParamDecl, CExpr, Type)]
voidPtrs) of
        ((ParamDecl
_, CExpr
f, Type
fTy):[(ParamDecl, CExpr, Type)]
_, (ParamDecl
_, CExpr
p, Type
pTy):[(ParamDecl, CExpr, Type)]
_) -> (CExpr, Type, CExpr, Type) -> Maybe (CExpr, Type, CExpr, Type)
forall a. a -> Maybe a
Just (CExpr
f, Type
fTy, CExpr
p, Type
pTy)
        ([(ParamDecl, CExpr, Type)], [(ParamDecl, CExpr, Type)])
_                              -> Maybe (CExpr, Type, CExpr, Type)
forall a. Maybe a
Nothing


-- | Extract the identifier from a CExpr if it's a simple variable or address of a variable.
getIdent :: CExpr -> Maybe Ident
getIdent :: CExpr -> Maybe Ident
getIdent (CVar Ident
ident NodeInfo
_)      = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ident
getIdent (CUnary CUnaryOp
CAdrOp CExpr
e NodeInfo
_) = CExpr -> Maybe Ident
getIdent CExpr
e
getIdent (CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_)       = CExpr -> Maybe Ident
getIdent CExpr
e
getIdent CExpr
_                   = Maybe Ident
forall a. Maybe a
Nothing


checkCall :: Map Ident Type -> [ParamDecl] -> [CExpr] -> Trav Env ()
checkCall :: Map Ident Type -> [ParamDecl] -> [CExpr] -> Trav Env ()
checkCall Map Ident Type
inferred [ParamDecl]
params [CExpr]
args = do
    [Type]
argTys <- (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
    case [(ParamDecl, CExpr, Type)] -> Maybe (CExpr, Type, CExpr, Type)
findCallbackPair ([ParamDecl] -> [CExpr] -> [Type] -> [(ParamDecl, CExpr, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ParamDecl]
params [CExpr]
args [Type]
argTys) of
        Just (CExpr
f, Type
_, CExpr
p, Type
pTy) ->
            case CExpr -> Maybe Ident
getIdent CExpr
f Maybe Ident -> (Ident -> Maybe Type) -> Maybe Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ident
ident -> String -> Map String Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> String
idName Ident
ident) Map String Type
inferredByName of
                Just Type
expectedTy ->
                    Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Bool
compatibleContext Type
expectedTy Type
pTy) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
                        NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
p) (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
                            Doc AnsiStyle
"callback expects context of 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
expectedTy)))
                             Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", but got" 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
pTy)))
                Maybe Type
Nothing -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe (CExpr, Type, CExpr, Type)
Nothing -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    inferredByName :: Map String Type
inferredByName = [(String, Type)] -> Map String Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Ident -> String
idName Ident
k, Type
v) | (Ident
k, Type
v) <- Map Ident Type -> [(Ident, Type)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Ident Type
inferred ]

-- | Find assignments to struct members that look like callback registration.
checkBlockItems :: Map Ident Type -> [CBlockItem] -> Trav Env ()
checkBlockItems :: Map Ident Type -> [CBlockItem] -> Trav Env ()
checkBlockItems Map Ident Type
inferred [CBlockItem]
items = do
    let assigns :: [(Ident, Ident, CExpr)]
assigns = (CBlockItem -> Maybe (Ident, Ident, CExpr))
-> [CBlockItem] -> [(Ident, Ident, CExpr)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CBlockItem -> Maybe (Ident, Ident, CExpr)
forall a.
CCompoundBlockItem a -> Maybe (Ident, Ident, CExpression a)
getAssign [CBlockItem]
items
    -- For each struct being assigned to, find its callback and object assignments.
    let groups :: Map String [(Ident, CExpr)]
groups = ([(Ident, CExpr)] -> [(Ident, CExpr)] -> [(Ident, CExpr)])
-> [(String, [(Ident, CExpr)])] -> Map String [(Ident, CExpr)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Ident, CExpr)] -> [(Ident, CExpr)] -> [(Ident, CExpr)]
forall a. [a] -> [a] -> [a]
(++) [ (Ident -> String
idName Ident
s, [(Ident
f, CExpr
v)]) | (Ident
s, Ident
f, CExpr
v) <- [(Ident, Ident, CExpr)]
assigns ]
    [[(Ident, CExpr)]]
-> ([(Ident, CExpr)] -> Trav Env ()) -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String [(Ident, CExpr)] -> [[(Ident, CExpr)]]
forall k a. Map k a -> [a]
Map.elems Map String [(Ident, CExpr)]
groups) (([(Ident, CExpr)] -> Trav Env ()) -> Trav Env ())
-> ([(Ident, CExpr)] -> Trav Env ()) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \[(Ident, CExpr)]
group -> do
        let cb :: Maybe CExpr
cb = [CExpr] -> Maybe CExpr
forall a. [a] -> Maybe a
listToMaybe [ CExpr
v | (Ident
f, CExpr
v) <- [(Ident, CExpr)]
group, String
"callback" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Ident -> String
idName Ident
f ]
        let obj :: Maybe CExpr
obj = [CExpr] -> Maybe CExpr
forall a. [a] -> Maybe a
listToMaybe [ CExpr
v | (Ident
f, CExpr
v) <- [(Ident, CExpr)]
group, String
"object" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Ident -> String
idName Ident
f ]
        case (Maybe CExpr
cb, Maybe CExpr
obj) of
            (Just CExpr
cbExpr, Just CExpr
objExpr) -> do
                Type
_ <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
cbExpr
                Type
objTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
objExpr
                case CExpr -> Maybe Ident
getIdent CExpr
cbExpr Maybe Ident -> (Ident -> Maybe Type) -> Maybe Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Ident
ident -> String -> Map String Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> String
idName Ident
ident) Map String Type
inferredByName of
                    Just Type
expectedTy ->
                        Bool -> Trav Env () -> Trav Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Bool
compatibleContext Type
expectedTy Type
objTy) (Trav Env () -> Trav Env ()) -> Trav Env () -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
                            NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
objExpr) (Doc AnsiStyle -> Trav Env ()) -> Doc AnsiStyle -> Trav Env ()
forall a b. (a -> b) -> a -> b
$
                                Doc AnsiStyle
"callback expects context of 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
expectedTy)))
                                 Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", but got" 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
objTy)))
                    Maybe Type
Nothing -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (Maybe CExpr, Maybe CExpr)
_ -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    inferredByName :: Map String Type
inferredByName = [(String, Type)] -> Map String Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Ident -> String
idName Ident
k, Type
v) | (Ident
k, Type
v) <- Map Ident Type -> [(Ident, Type)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Ident Type
inferred ]

    getAssign :: CCompoundBlockItem a -> Maybe (Ident, Ident, CExpression a)
getAssign (CBlockStmt (CExpr (Just (CAssign CAssignOp
_ (CMember (CVar Ident
s a
_) Ident
f Bool
_ a
_) CExpression a
v a
_)) a
_)) = (Ident, Ident, CExpression a)
-> Maybe (Ident, Ident, CExpression a)
forall a. a -> Maybe a
Just (Ident
s, Ident
f, CExpression a
v)
    getAssign CCompoundBlockItem a
_ = Maybe (Ident, Ident, CExpression a)
forall a. Maybe a
Nothing


linter :: Map Ident Type -> AstActions (TravT Env Identity)
linter :: Map Ident Type -> AstActions (TravT Env Identity)
linter Map Ident Type
inferred = 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
_ -> do
            [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
                FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_ ->
                    Map Ident Type -> [ParamDecl] -> [CExpr] -> Trav Env ()
checkCall Map Ident Type
inferred [ParamDecl]
params [CExpr]
args
                PtrType (FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_) TypeQuals
_ Attributes
_ ->
                    Map Ident Type -> [ParamDecl] -> [CExpr] -> Trav Env ()
checkCall Map Ident Type
inferred [ParamDecl]
params [CExpr]
args
                Type
_ -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Trav Env ()
act

        CExpr
_ -> Trav Env ()
act

    , doBlockItems :: [CBlockItem] -> Trav Env () -> Trav Env ()
doBlockItems = \[CBlockItem]
items Trav Env ()
act -> do
        Map Ident Type -> [CBlockItem] -> Trav Env ()
checkBlockItems Map Ident Type
inferred [CBlockItem]
items
        Trav Env ()
act
    }


-- | Collector for inferred callback types.
collector :: AstActions (TravT Env Identity)
collector :: AstActions (TravT Env Identity)
collector = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doIdentDecl :: IdentDecl -> Trav Env () -> Trav Env ()
doIdentDecl = \IdentDecl
node Trav Env ()
act -> case IdentDecl
node of
        FunctionDef (FunDef (VarDecl (VarName Ident
ident Maybe AsmName
_) DeclAttrs
_ (FunctionType (FunType Type
_ (ParamDecl (VarDecl (VarName Ident
arg1 Maybe AsmName
_) DeclAttrs
_ Type
TY_void_ptr) NodeInfo
_:[ParamDecl]
_) Bool
_) Attributes
_)) (CCompound [Ident]
_ [CBlockItem]
items NodeInfo
_) NodeInfo
_) -> do
            case Ident -> [CBlockItem] -> Maybe CExpr
forall a. Ident -> [CCompoundBlockItem a] -> Maybe (CExpression a)
findCast Ident
arg1 [CBlockItem]
items of
                Just CExpr
tyExpr -> do
                    Type
ty <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
tyExpr
                    (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env { inferredTypes :: Map Ident Type
inferredTypes = Ident -> Type -> Map Ident Type -> Map Ident Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
ident Type
ty (Env -> Map Ident Type
inferredTypes Env
env) }
                Maybe CExpr
Nothing -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Trav Env ()
act
        IdentDecl
_ -> Trav Env ()
act
    }
  where
    findCast :: Ident -> [CCompoundBlockItem a] -> Maybe (CExpression a)
findCast Ident
arg (CBlockDecl (CDecl [CDeclarationSpecifier a]
_ [(Just CDeclarator a
_, Just (CInitExpr tyExpr :: CExpression a
tyExpr@(CCast CDeclaration a
_ (CVar Ident
arg' a
_) a
_) a
_), Maybe (CExpression a)
_)] a
_) : [CCompoundBlockItem a]
_)
        | Ident -> String
idName Ident
arg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> String
idName Ident
arg' = CExpression a -> Maybe (CExpression a)
forall a. a -> Maybe a
Just CExpression a
tyExpr
    findCast Ident
arg (CCompoundBlockItem a
_ : [CCompoundBlockItem a]
ss) = Ident -> [CCompoundBlockItem a] -> Maybe (CExpression a)
findCast Ident
arg [CCompoundBlockItem a]
ss
    findCast Ident
_ [] = Maybe (CExpression a)
forall a. Maybe a
Nothing


analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse GlobalDecls
decls = do
    AstActions (TravT Env Identity) -> GlobalDecls -> Trav Env ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst AstActions (TravT Env Identity)
collector GlobalDecls
decls
    Map Ident Type
inferred <- Env -> Map Ident Type
inferredTypes (Env -> Map Ident Type)
-> TravT Env Identity Env -> TravT Env Identity (Map Ident Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TravT Env Identity Env
forall s. Trav s s
getUserState
    AstActions (TravT Env Identity) -> GlobalDecls -> Trav Env ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst (Map Ident Type -> AstActions (TravT Env Identity)
linter Map Ident Type
inferred) GlobalDecls
decls


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"callback-data", Text
"Checks that the context pointer passed to a callback matches the expected type inferred from the callback's first argument."))