{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE ViewPatterns      #-}
module Tokstyle.C.Linter.CallbackDiscipline (descr) where

import           Control.Monad                   (unless, when)
import           Data.Functor.Identity           (Identity)
import           Data.List                       (intercalate, isInfixOf,
                                                  isPrefixOf, isSuffixOf)
import qualified Data.Map.Strict                 as Map
import           Data.Maybe                      (mapMaybe)
import           Data.Set                        (Set)
import qualified Data.Set                        as Set
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemRep      (CompTypeRef (..), FunDef (..),
                                                  FunType (..),
                                                  GlobalDecls (..),
                                                  IdentDecl (..),
                                                  ParamDecl (..), Type (..),
                                                  TypeName (..), VarDecl (..),
                                                  VarName (..))
import           Language.C.Analysis.TravMonad   (Trav, TravT)
import           Language.C.Analysis.TypeUtils   (canonicalType)
import           Language.C.Data.Ident           (Ident (..), SUERef (..))
import           Language.C.Data.Node            (NodeInfo)
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST
import           Language.C.Syntax.Constants     (CInteger (..))
import           Prettyprinter                   (pretty, (<+>))
import qualified Tokstyle.C.Env                  as Env
import           Tokstyle.C.Env                  (DiagnosticLevel (..), Env,
                                                  recordLinterError,
                                                  recordRichError)
import           Tokstyle.C.ObjectSystem         (CallbackSlot (..),
                                                  ObjectInfo (..),
                                                  discoverObjectTypes,
                                                  isCallbackMember, isFuncPtr,
                                                  isUserdataMember)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)


-- | Analyze a function body to see if it behaves like a registry.
isRegistryBehavior :: Map.Map String ObjectInfo -> FunDef -> Set CallbackSlot
isRegistryBehavior :: Map [Char] ObjectInfo -> FunDef -> Set CallbackSlot
isRegistryBehavior Map [Char] ObjectInfo
objs (FunDef (VarDecl VarName
_ DeclAttrs
_ (FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_)) Stmt
body NodeInfo
_) =
    let
        paramInfos :: [([Char], Type)]
paramInfos = (ParamDecl -> Maybe ([Char], Type))
-> [ParamDecl] -> [([Char], Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ParamDecl -> Maybe ([Char], Type)
getParamInfo [ParamDecl]
params
        getParamInfo :: ParamDecl -> Maybe ([Char], Type)
getParamInfo (ParamDecl (VarDecl (VarName (Ident [Char]
n Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
ty) NodeInfo
_) = ([Char], Type) -> Maybe ([Char], Type)
forall a. a -> Maybe a
Just ([Char]
n, Type
ty)
        getParamInfo ParamDecl
_ = Maybe ([Char], Type)
forall a. Maybe a
Nothing

        paramNames :: [[Char]]
paramNames = (([Char], Type) -> [Char]) -> [([Char], Type)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Type) -> [Char]
forall a b. (a, b) -> a
fst [([Char], Type)]
paramInfos

        -- Check if an expression is a parameter.
        isParam :: CExpression a -> Bool
isParam (CVar (Ident [Char]
n Int
_ NodeInfo
_) a
_) = [Char]
n [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
paramNames
        isParam CExpression a
_                      = Bool
False

        -- Resolve the struct type of a variable if it's a parameter.
        getStructType :: CExpression a -> Maybe [Char]
getStructType (CVar (Ident [Char]
n Int
_ NodeInfo
_) a
_) =
            case [Char] -> [([Char], Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
n [([Char], Type)]
paramInfos of
                Just (Type -> Type
canonicalType -> PtrType (DirectType (TyComp (CompTypeRef (NamedRef (Ident [Char]
s Int
_ NodeInfo
_)) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
                Maybe Type
_ -> Maybe [Char]
forall a. Maybe a
Nothing
        getStructType CExpression a
_ = Maybe [Char]
forall a. Maybe a
Nothing

        -- Check if a member access is to a callback field of a known object type.
        getCallbackSlot :: CExpression a -> Maybe CallbackSlot
getCallbackSlot (CMember CExpression a
structExpr (Ident [Char]
fieldName Int
_ NodeInfo
_) Bool
_ a
_) =
            case CExpression a -> Maybe [Char]
forall {a}. CExpression a -> Maybe [Char]
getStructType CExpression a
structExpr of
                Just [Char]
s  -> if Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isCallbackMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName Bool -> Bool -> Bool
|| Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isUserdataMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName
                           then CallbackSlot -> Maybe CallbackSlot
forall a. a -> Maybe a
Just ([Char] -> [Char] -> CallbackSlot
CallbackSlot [Char]
s [Char]
fieldName)
                           else Maybe CallbackSlot
forall a. Maybe a
Nothing
                Maybe [Char]
Nothing -> Maybe CallbackSlot
forall a. Maybe a
Nothing
        getCallbackSlot (CIndex CExpression a
l CExpression a
_ a
_) = CExpression a -> Maybe CallbackSlot
getCallbackSlot CExpression a
l
        getCallbackSlot CExpression a
_ = Maybe CallbackSlot
forall a. Maybe a
Nothing

    in (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
forall {a}. CExpression a -> Bool
isParam CExpr -> Maybe CallbackSlot
forall {a}. CExpression a -> Maybe CallbackSlot
getCallbackSlot Stmt
body
isRegistryBehavior Map [Char] ObjectInfo
_ FunDef
_ = Set CallbackSlot
forall a. Set a
Set.empty


isRegistryStat :: (CExpr -> Bool) -> (CExpr -> Maybe CallbackSlot) -> CStat -> Set CallbackSlot
isRegistryStat :: (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot Stmt
stat = case Stmt
stat of
    CExpr (Just (CAssign CAssignOp
_ CExpr
l CExpr
r NodeInfo
_)) NodeInfo
_ ->
        if (CExpr -> Bool
isParam CExpr
r Bool -> Bool -> Bool
|| CExpr -> Bool
isNull CExpr
r)
        then case CExpr -> Maybe CallbackSlot
getSlot CExpr
l of
            Just CallbackSlot
s  -> CallbackSlot -> Set CallbackSlot
forall a. a -> Set a
Set.singleton CallbackSlot
s
            Maybe CallbackSlot
Nothing -> Set CallbackSlot
forall a. Set a
Set.empty
        else Set CallbackSlot
forall a. Set a
Set.empty
    CIf CExpr
_ Stmt
t Maybe Stmt
e NodeInfo
_ -> (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot Stmt
t Set CallbackSlot -> Set CallbackSlot -> Set CallbackSlot
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set CallbackSlot
-> (Stmt -> Set CallbackSlot) -> Maybe Stmt -> Set CallbackSlot
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CallbackSlot
forall a. Set a
Set.empty ((CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot) Maybe Stmt
e
    CFor Either (Maybe CExpr) (CDeclaration NodeInfo)
_ Maybe CExpr
_ Maybe CExpr
_ Stmt
s NodeInfo
_ -> (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot Stmt
s
    CWhile CExpr
_ Stmt
s Bool
_ NodeInfo
_ -> (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot Stmt
s
    CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_ -> [Set CallbackSlot] -> Set CallbackSlot
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CallbackSlot] -> Set CallbackSlot)
-> [Set CallbackSlot] -> Set CallbackSlot
forall a b. (a -> b) -> a -> b
$ (CCompoundBlockItem NodeInfo -> Set CallbackSlot)
-> [CCompoundBlockItem NodeInfo] -> [Set CallbackSlot]
forall a b. (a -> b) -> [a] -> [b]
map ((CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot)
-> CCompoundBlockItem NodeInfo
-> Set CallbackSlot
isRegistryItem CExpr -> Bool
isParam CExpr -> Maybe CallbackSlot
getSlot) [CCompoundBlockItem NodeInfo]
items
    Stmt
_ -> Set CallbackSlot
forall a. Set a
Set.empty
  where
    isRegistryItem :: (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot)
-> CCompoundBlockItem NodeInfo
-> Set CallbackSlot
isRegistryItem CExpr -> Bool
p CExpr -> Maybe CallbackSlot
c (CBlockStmt Stmt
s) = (CExpr -> Bool)
-> (CExpr -> Maybe CallbackSlot) -> Stmt -> Set CallbackSlot
isRegistryStat CExpr -> Bool
p CExpr -> Maybe CallbackSlot
c Stmt
s
    isRegistryItem CExpr -> Bool
_ CExpr -> Maybe CallbackSlot
_ CCompoundBlockItem NodeInfo
_              = Set CallbackSlot
forall a. Set a
Set.empty



isNull :: CExpr -> Bool
isNull :: CExpr -> Bool
isNull (CVar (Ident [Char]
n Int
_ NodeInfo
_) NodeInfo
_)                  = [Char]
n [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"NULL" Bool -> Bool -> Bool
|| [Char]
n [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"nullptr"
isNull (CConst (CIntConst (CInteger Integer
0 CIntRepr
_ Flags CIntFlag
_) NodeInfo
_)) = Bool
True
isNull CExpr
_                                       = Bool
False


countComplexity :: CStat -> Int
countComplexity :: Stmt -> Int
countComplexity (CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (CCompoundBlockItem NodeInfo -> Int)
-> [CCompoundBlockItem NodeInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CCompoundBlockItem NodeInfo -> Int
forall {t} {a}. Num t => CCompoundBlockItem a -> t
countItem [CCompoundBlockItem NodeInfo]
items
  where
    countItem :: CCompoundBlockItem a -> t
countItem (CBlockStmt CStatement a
s) = CStatement a -> t
countStat CStatement a
s
    countItem (CBlockDecl CDeclaration a
_) = t
1
    countItem CCompoundBlockItem a
_              = t
0

    countStat :: CStatement a -> t
countStat (CCompound [Ident]
_ [CCompoundBlockItem a]
items' a
_) = [t] -> t
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([t] -> t) -> [t] -> t
forall a b. (a -> b) -> a -> b
$ (CCompoundBlockItem a -> t) -> [CCompoundBlockItem a] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map CCompoundBlockItem a -> t
countItem [CCompoundBlockItem a]
items'
    countStat (CIf CExpression a
_ CStatement a
t Maybe (CStatement a)
e a
_)          = t
1 t -> t -> t
forall a. Num a => a -> a -> a
+ CStatement a -> t
countStat CStatement a
t t -> t -> t
forall a. Num a => a -> a -> a
+ t -> (CStatement a -> t) -> Maybe (CStatement a) -> t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe t
0 CStatement a -> t
countStat Maybe (CStatement a)
e
    countStat (CFor Either (Maybe (CExpression a)) (CDeclaration a)
_ Maybe (CExpression a)
_ Maybe (CExpression a)
_ CStatement a
s a
_)       = t
1 t -> t -> t
forall a. Num a => a -> a -> a
+ CStatement a -> t
countStat CStatement a
s
    countStat (CWhile CExpression a
_ CStatement a
s Bool
_ a
_)       = t
1 t -> t -> t
forall a. Num a => a -> a -> a
+ CStatement a -> t
countStat CStatement a
s
    countStat (CExpr Maybe (CExpression a)
_ a
_)            = t
1
    countStat (CReturn Maybe (CExpression a)
_ a
_)          = t
1
    countStat CStatement a
_                      = t
1
countComplexity Stmt
_ = Int
1


isAllowedCall :: String -> Bool
isAllowedCall :: [Char] -> Bool
isAllowedCall [Char]
name = [Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"assert", [Char]
"__assert_fail", [Char]
"memcpy", [Char]
"memset", [Char]
"tox_lock", [Char]
"tox_unlock", [Char]
"pthread_mutex_lock", [Char]
"pthread_mutex_unlock", [Char]
"random_u64", [Char]
"UINT32_C", [Char]
"UINT16_C", [Char]
"UINT8_C"]


checkCalls :: NodeInfo -> String -> CStat -> TravT Env Identity ()
checkCalls :: NodeInfo -> [Char] -> Stmt -> TravT Env Identity ()
checkCalls NodeInfo
info [Char]
funcName Stmt
stat = Stmt -> TravT Env Identity ()
checkStat Stmt
stat
  where
    checkStat :: Stmt -> TravT Env Identity ()
checkStat (CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_) = (CCompoundBlockItem NodeInfo -> TravT Env Identity ())
-> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CCompoundBlockItem NodeInfo -> TravT Env Identity ()
checkItem [CCompoundBlockItem NodeInfo]
items
    checkStat (CIf CExpr
_ Stmt
t Maybe Stmt
e NodeInfo
_)          = Stmt -> TravT Env Identity ()
checkStat Stmt
t TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TravT Env Identity ()
-> (Stmt -> TravT Env Identity ())
-> Maybe Stmt
-> TravT Env Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Stmt -> TravT Env Identity ()
checkStat Maybe Stmt
e
    checkStat (CFor Either (Maybe CExpr) (CDeclaration NodeInfo)
_ Maybe CExpr
_ Maybe CExpr
_ Stmt
s NodeInfo
_)       = Stmt -> TravT Env Identity ()
checkStat Stmt
s
    checkStat (CWhile CExpr
cond Stmt
s Bool
isDo NodeInfo
a) = do
        Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CExpr -> Bool -> Bool
forall {a}. CExpression a -> Bool -> Bool
isAssertLoop CExpr
cond Bool
isDo) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError NodeInfo
a (Doc AnsiStyle
"registry 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
funcName) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"contains a loop")
        Stmt -> TravT Env Identity ()
checkStat Stmt
s
    checkStat (CExpr (Just CExpr
e) NodeInfo
_)     = CExpr -> TravT Env Identity ()
forall {a}. CExpression a -> TravT Env Identity ()
checkExpr CExpr
e
    checkStat Stmt
_                      = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    isAssertLoop :: CExpression a -> Bool -> Bool
isAssertLoop CExpression a
cond Bool
True = CExpression a -> Bool
forall {a}. CExpression a -> Bool
isConstantZero CExpression a
cond
    isAssertLoop CExpression a
_ Bool
_       = Bool
False

    isConstantZero :: CExpression a -> Bool
isConstantZero (CConst (CIntConst (CInteger Integer
0 CIntRepr
_ Flags CIntFlag
_) a
_)) = Bool
True
    isConstantZero CExpression a
_                                       = Bool
False

    checkItem :: CCompoundBlockItem NodeInfo -> TravT Env Identity ()
checkItem (CBlockStmt Stmt
s) = Stmt -> TravT Env Identity ()
checkStat Stmt
s
    checkItem CCompoundBlockItem NodeInfo
_              = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkExpr :: CExpression a -> TravT Env Identity ()
checkExpr (CCall (CVar (Ident [Char]
name Int
_ NodeInfo
_) a
_) [CExpression a]
_ a
_) =
        Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> Bool
isAllowedCall [Char]
name) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
            NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> TravT Env Identity ()
recordRichError NodeInfo
info DiagnosticLevel
ErrorLevel
                (Doc AnsiStyle
"registry 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
funcName) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"calls non-trivial 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
name))
                []
                [(DiagnosticLevel
NoteLevel, Doc AnsiStyle
"registry functions should be side-effect free and remain simple")]
    checkExpr (CCond CExpression a
c Maybe (CExpression a)
t CExpression a
e a
_) = CExpression a -> TravT Env Identity ()
checkExpr CExpression a
c TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TravT Env Identity ()
-> (CExpression a -> TravT Env Identity ())
-> Maybe (CExpression a)
-> TravT Env Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CExpression a -> TravT Env Identity ()
checkExpr Maybe (CExpression a)
t TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpression a -> TravT Env Identity ()
checkExpr CExpression a
e
    checkExpr (CBinary CBinaryOp
_ CExpression a
l CExpression a
r a
_) = CExpression a -> TravT Env Identity ()
checkExpr CExpression a
l TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpression a -> TravT Env Identity ()
checkExpr CExpression a
r
    checkExpr (CUnary CUnaryOp
_ CExpression a
e a
_) = CExpression a -> TravT Env Identity ()
checkExpr CExpression a
e
    checkExpr (CAssign CAssignOp
_ CExpression a
l CExpression a
r a
_) = CExpression a -> TravT Env Identity ()
checkExpr CExpression a
l TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CExpression a -> TravT Env Identity ()
checkExpr CExpression a
r
    checkExpr CExpression a
_ = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


checkRegistrySideEffects :: Map.Map String ObjectInfo -> FunDef -> TravT Env Identity ()
checkRegistrySideEffects :: Map [Char] ObjectInfo -> FunDef -> TravT Env Identity ()
checkRegistrySideEffects Map [Char] ObjectInfo
objs (FunDef (VarDecl (VarName (Ident [Char]
name Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
_) Stmt
body NodeInfo
_) = do
    let
        -- Find all assignments.
        checkItem :: CCompoundBlockItem NodeInfo -> TravT Env Identity ()
checkItem (CBlockStmt Stmt
s) = Stmt -> TravT Env Identity ()
checkStat Stmt
s
        checkItem CCompoundBlockItem NodeInfo
_              = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        checkStat :: Stmt -> TravT Env Identity ()
checkStat (CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_) = (CCompoundBlockItem NodeInfo -> TravT Env Identity ())
-> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CCompoundBlockItem NodeInfo -> TravT Env Identity ()
checkItem [CCompoundBlockItem NodeInfo]
items
        checkStat (CIf CExpr
_ Stmt
t Maybe Stmt
e NodeInfo
_)          = Stmt -> TravT Env Identity ()
checkStat Stmt
t TravT Env Identity ()
-> TravT Env Identity () -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> TravT Env Identity b -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TravT Env Identity ()
-> (Stmt -> TravT Env Identity ())
-> Maybe Stmt
-> TravT Env Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Stmt -> TravT Env Identity ()
checkStat Maybe Stmt
e
        checkStat (CFor Either (Maybe CExpr) (CDeclaration NodeInfo)
_ Maybe CExpr
_ Maybe CExpr
_ Stmt
s NodeInfo
_)       = Stmt -> TravT Env Identity ()
checkStat Stmt
s
        checkStat (CWhile CExpr
_ Stmt
s Bool
_ NodeInfo
_)       = Stmt -> TravT Env Identity ()
checkStat Stmt
s
        checkStat (CExpr (Just (CAssign CAssignOp
_ CExpr
l CExpr
_ NodeInfo
_)) NodeInfo
_) = CExpr -> TravT Env Identity ()
checkLHS CExpr
l
        checkStat Stmt
_                      = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        checkLHS :: CExpr -> TravT Env Identity ()
checkLHS CExpr
expr = case CExpr
expr of
            CMember CExpr
structExpr (Ident [Char]
fieldName Int
_ NodeInfo
_) Bool
_ NodeInfo
_ -> do
                Type
ty <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
structExpr
                case Type -> Type
canonicalType Type
ty of
                    PtrType (DirectType (TyComp (CompTypeRef (NamedRef (Ident [Char]
s Int
_ NodeInfo
_)) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_ ->
                        Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isCallbackMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName Bool -> Bool -> Bool
|| Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isUserdataMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                            CExpr -> TravT Env Identity ()
forall {ast :: * -> *}.
(Annotated ast, Pretty (ast NodeInfo)) =>
ast NodeInfo -> TravT Env Identity ()
recordError CExpr
expr
                    DirectType (TyComp (CompTypeRef (NamedRef (Ident [Char]
s Int
_ NodeInfo
_)) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ ->
                        Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isCallbackMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName Bool -> Bool -> Bool
|| Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isUserdataMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                            CExpr -> TravT Env Identity ()
forall {ast :: * -> *}.
(Annotated ast, Pretty (ast NodeInfo)) =>
ast NodeInfo -> TravT Env Identity ()
recordError CExpr
expr
                    Type
_ -> () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            CIndex CExpr
l CExpr
_ NodeInfo
_ -> CExpr -> TravT Env Identity ()
checkLHS CExpr
l
            CExpr
_ -> () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        recordError :: ast NodeInfo -> TravT Env Identity ()
recordError ast NodeInfo
l =
            NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> TravT Env Identity ()
recordRichError (ast NodeInfo -> NodeInfo
forall a. ast a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation ast NodeInfo
l) DiagnosticLevel
ErrorLevel
                (Doc AnsiStyle
"registry 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
name) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"mutates non-callback field" 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> [Char]
forall a. Show a => a -> [Char]
show (ast NodeInfo -> Doc
forall p. Pretty p => p -> Doc
C.pretty ast NodeInfo
l))))
                []
                [(DiagnosticLevel
NoteLevel, Doc AnsiStyle
"registry functions should only set callbacks and their associated userdata")]

    Stmt -> TravT Env Identity ()
checkStat Stmt
body
checkRegistrySideEffects Map [Char] ObjectInfo
_ FunDef
_ = () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


checkCallbackMutation :: Map.Map String ObjectInfo -> Map.Map CallbackSlot (Set String) -> CExpr -> TravT Env Identity ()
checkCallbackMutation :: Map [Char] ObjectInfo
-> Map CallbackSlot (Set [Char]) -> CExpr -> TravT Env Identity ()
checkCallbackMutation Map [Char] ObjectInfo
objs Map CallbackSlot (Set [Char])
registryMap CExpr
expr = do
    Maybe CallbackSlot
mSlot <- CExpr -> TravT Env Identity (Maybe CallbackSlot)
forall {m :: * -> *}.
MonadTrav m =>
CExpr -> m (Maybe CallbackSlot)
getCallbackSlot CExpr
expr
    case Maybe CallbackSlot
mSlot of
        Maybe CallbackSlot
Nothing -> () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just CallbackSlot
slot -> do
            [[Char]]
ctx <- Trav Env [[Char]]
Env.getCtx
            let currentFunc :: [Char]
currentFunc = case [ [Char]
f | [Char]
f <- [[Char]]
ctx, [Char]
"func:" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
f ] of
                    ([Char]
f:[[Char]]
_) -> Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
5 [Char]
f
                    []    -> [Char]
""

            let allowed :: Set [Char]
allowed = Set [Char]
-> CallbackSlot -> Map CallbackSlot (Set [Char]) -> Set [Char]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set [Char]
forall a. Set a
Set.empty CallbackSlot
slot Map CallbackSlot (Set [Char])
registryMap

            Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
currentFunc [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
allowed Bool -> Bool -> Bool
|| [Char] -> Bool
isConstructor [Char]
currentFunc Bool -> Bool -> Bool
|| [Char] -> Bool
isDestructor [Char]
currentFunc) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ do
                let msg :: Doc ann
msg = Doc ann
"mutation of callback/userdata field" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
backticks ([Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Doc -> [Char]
forall a. Show a => a -> [Char]
show (CExpr -> Doc
forall p. Pretty p => p -> Doc
C.pretty CExpr
expr))) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"outside of a registry function"
                let footers :: [(DiagnosticLevel, Doc ann)]
footers = if Set [Char] -> Bool
forall a. Set a -> Bool
Set.null Set [Char]
allowed
                              then []
                              else [(DiagnosticLevel
HelpLevel, Doc ann
"use one of these registry functions instead:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList Set [Char]
allowed)))]
                NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> TravT Env Identity ()
recordRichError (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
expr) DiagnosticLevel
ErrorLevel Doc AnsiStyle
forall {ann}. Doc ann
msg [] [(DiagnosticLevel, Doc AnsiStyle)]
forall {ann}. [(DiagnosticLevel, Doc ann)]
footers
  where
    isConstructor :: [Char] -> Bool
isConstructor [Char]
f = [Char]
"_new" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
f Bool -> Bool -> Bool
|| [Char]
"new_" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
f
    isDestructor :: [Char] -> Bool
isDestructor [Char]
f  = [Char]
"_kill" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
f Bool -> Bool -> Bool
|| [Char]
"kill_" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
f

    getCallbackSlot :: CExpr -> m (Maybe CallbackSlot)
getCallbackSlot (CMember CExpr
structExpr (Ident [Char]
fieldName Int
_ NodeInfo
_) Bool
_ NodeInfo
_) = do
        Type
ty' <- [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
structExpr
        case Type -> Type
canonicalType Type
ty' of
            PtrType (DirectType (TyComp (CompTypeRef (NamedRef (Ident [Char]
s Int
_ NodeInfo
_)) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_) TypeQuals
_ Attributes
_ ->
                Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CallbackSlot -> m (Maybe CallbackSlot))
-> Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a b. (a -> b) -> a -> b
$ if Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isCallbackMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName Bool -> Bool -> Bool
|| Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isUserdataMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName
                         then CallbackSlot -> Maybe CallbackSlot
forall a. a -> Maybe a
Just ([Char] -> [Char] -> CallbackSlot
CallbackSlot [Char]
s [Char]
fieldName)
                         else Maybe CallbackSlot
forall a. Maybe a
Nothing
            DirectType (TyComp (CompTypeRef (NamedRef (Ident [Char]
s Int
_ NodeInfo
_)) CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ ->
                Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CallbackSlot -> m (Maybe CallbackSlot))
-> Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a b. (a -> b) -> a -> b
$ if Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isCallbackMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName Bool -> Bool -> Bool
|| Map [Char] ObjectInfo -> [Char] -> [Char] -> Bool
isUserdataMember Map [Char] ObjectInfo
objs [Char]
s [Char]
fieldName
                         then CallbackSlot -> Maybe CallbackSlot
forall a. a -> Maybe a
Just ([Char] -> [Char] -> CallbackSlot
CallbackSlot [Char]
s [Char]
fieldName)
                         else Maybe CallbackSlot
forall a. Maybe a
Nothing
            Type
_ -> Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CallbackSlot
forall a. Maybe a
Nothing
    getCallbackSlot (CIndex CExpr
l CExpr
_ NodeInfo
_) = CExpr -> m (Maybe CallbackSlot)
getCallbackSlot CExpr
l
    getCallbackSlot CExpr
_ = Maybe CallbackSlot -> m (Maybe CallbackSlot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CallbackSlot
forall a. Maybe a
Nothing


linter :: Map.Map String ObjectInfo -> Map.Map CallbackSlot (Set String) -> Set String -> AstActions (TravT Env Identity)
linter :: Map [Char] ObjectInfo
-> Map CallbackSlot (Set [Char])
-> Set [Char]
-> AstActions (TravT Env Identity)
linter Map [Char] ObjectInfo
objs Map CallbackSlot (Set [Char])
registryMap Set [Char]
registries = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doIdentDecl = \IdentDecl
node TravT Env Identity ()
act -> case IdentDecl
node of
        FunctionDef f :: FunDef
f@(FunDef (VarDecl (VarName (Ident [Char]
name Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
_) Stmt
body NodeInfo
_) -> do
            let isRegistry :: Bool
isRegistry = [Char]
name [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
registries
            Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRegistry (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ do
                let complexity :: Int
complexity = Stmt -> Int
countComplexity Stmt
body
                Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
complexity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                    NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (Stmt -> NodeInfo
forall a. CStatement a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation Stmt
body) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                        Doc AnsiStyle
"registry 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 ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
name) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"is too complex (" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
complexity Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"statements)"

                NodeInfo -> [Char] -> Stmt -> TravT Env Identity ()
checkCalls (Stmt -> NodeInfo
forall a. CStatement a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation Stmt
body) [Char]
name Stmt
body
                Map [Char] ObjectInfo -> FunDef -> TravT Env Identity ()
checkRegistrySideEffects Map [Char] ObjectInfo
objs FunDef
f

            [Char] -> TravT Env Identity ()
Env.pushCtx ([Char] -> TravT Env Identity ())
-> [Char] -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"func:" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name
            TravT Env Identity ()
act
            TravT Env Identity ()
Env.popCtx
        IdentDecl
_ -> TravT Env Identity ()
act

    , doExpr = \CExpr
node TravT Env Identity ()
act -> case CExpr
node of
        CAssign CAssignOp
_ CExpr
l CExpr
_ NodeInfo
_ -> do
            Map [Char] ObjectInfo
-> Map CallbackSlot (Set [Char]) -> CExpr -> TravT Env Identity ()
checkCallbackMutation Map [Char] ObjectInfo
objs Map CallbackSlot (Set [Char])
registryMap CExpr
l
            TravT Env Identity ()
act
        CExpr
_ -> TravT Env Identity ()
act
    }


collectRegistries :: Map.Map String ObjectInfo -> GlobalDecls -> Map.Map CallbackSlot (Set String)
collectRegistries :: Map [Char] ObjectInfo
-> GlobalDecls -> Map CallbackSlot (Set [Char])
collectRegistries Map [Char] ObjectInfo
objs (GlobalDecls Map Ident IdentDecl
objs' Map SUERef TagDef
_ Map Ident TypeDef
_) =
    (Set [Char] -> Set [Char] -> Set [Char])
-> [Map CallbackSlot (Set [Char])] -> Map CallbackSlot (Set [Char])
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set [Char] -> Set [Char] -> Set [Char]
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Map CallbackSlot (Set [Char])] -> Map CallbackSlot (Set [Char]))
-> (Map Ident IdentDecl -> [Map CallbackSlot (Set [Char])])
-> Map Ident IdentDecl
-> Map CallbackSlot (Set [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdentDecl -> Maybe (Map CallbackSlot (Set [Char])))
-> [IdentDecl] -> [Map CallbackSlot (Set [Char])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe IdentDecl -> Maybe (Map CallbackSlot (Set [Char]))
isReg ([IdentDecl] -> [Map CallbackSlot (Set [Char])])
-> (Map Ident IdentDecl -> [IdentDecl])
-> Map Ident IdentDecl
-> [Map CallbackSlot (Set [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Ident IdentDecl -> [IdentDecl]
forall k a. Map k a -> [a]
Map.elems (Map Ident IdentDecl -> Map CallbackSlot (Set [Char]))
-> Map Ident IdentDecl -> Map CallbackSlot (Set [Char])
forall a b. (a -> b) -> a -> b
$ Map Ident IdentDecl
objs'
  where
    isReg :: IdentDecl -> Maybe (Map CallbackSlot (Set [Char]))
isReg (FunctionDef f :: FunDef
f@(FunDef (VarDecl (VarName (Ident [Char]
name Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
_) Stmt
_ NodeInfo
_)) =
        let slots :: Set CallbackSlot
slots = Map [Char] ObjectInfo -> FunDef -> Set CallbackSlot
isRegistryBehavior Map [Char] ObjectInfo
objs FunDef
f
        in if Set CallbackSlot -> Bool
forall a. Set a -> Bool
Set.null Set CallbackSlot
slots
           then Maybe (Map CallbackSlot (Set [Char]))
forall a. Maybe a
Nothing
           else Map CallbackSlot (Set [Char])
-> Maybe (Map CallbackSlot (Set [Char]))
forall a. a -> Maybe a
Just (Map CallbackSlot (Set [Char])
 -> Maybe (Map CallbackSlot (Set [Char])))
-> Map CallbackSlot (Set [Char])
-> Maybe (Map CallbackSlot (Set [Char]))
forall a b. (a -> b) -> a -> b
$ [(CallbackSlot, Set [Char])] -> Map CallbackSlot (Set [Char])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (CallbackSlot
s, [Char] -> Set [Char]
forall a. a -> Set a
Set.singleton [Char]
name) | CallbackSlot
s <- Set CallbackSlot -> [CallbackSlot]
forall a. Set a -> [a]
Set.toList Set CallbackSlot
slots ]
    isReg IdentDecl
_ = Maybe (Map CallbackSlot (Set [Char]))
forall a. Maybe a
Nothing


analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> TravT Env Identity ()
analyse GlobalDecls
decls = do
    let objs :: Map [Char] ObjectInfo
objs = GlobalDecls -> Map [Char] ObjectInfo
discoverObjectTypes GlobalDecls
decls
    let registryMap :: Map CallbackSlot (Set [Char])
registryMap = Map [Char] ObjectInfo
-> GlobalDecls -> Map CallbackSlot (Set [Char])
collectRegistries Map [Char] ObjectInfo
objs GlobalDecls
decls
    let registries :: Set [Char]
registries = [Set [Char]] -> Set [Char]
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set [Char]] -> Set [Char]) -> [Set [Char]] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ Map CallbackSlot (Set [Char]) -> [Set [Char]]
forall k a. Map k a -> [a]
Map.elems Map CallbackSlot (Set [Char])
registryMap
    AstActions (TravT Env Identity)
-> GlobalDecls -> TravT Env Identity ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
forall (f :: * -> *).
Applicative f =>
AstActions f -> GlobalDecls -> f ()
traverseAst (Map [Char] ObjectInfo
-> Map CallbackSlot (Set [Char])
-> Set [Char]
-> AstActions (TravT Env Identity)
linter Map [Char] ObjectInfo
objs Map CallbackSlot (Set [Char])
registryMap Set [Char]
registries) GlobalDecls
decls


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> TravT Env Identity (), (Text, Text))
descr = (GlobalDecls -> TravT Env Identity ()
analyse, (Text
"callback-discipline", [Text] -> Text
Text.unlines
    [ Text
"Ensures callback discipline is followed."
    , Text
""
    , Text
"Callback and userdata fields should only be mutated within registry"
    , Text
"functions (functions that simply assign a parameter to a callback field)."
    , Text
"Registry functions themselves must remain simple and side-effect free."
    ]))