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

import           Data.Functor.Identity           (Identity)
import           Data.List                       (isPrefixOf)
import           Data.Maybe                      (mapMaybe)
import           Data.Text                       (Text)
import           Language.C                      (Annotated (annotation),
                                                  CCompoundBlockItem (CBlockDecl),
                                                  CDeclaration (CDecl),
                                                  CDeclarator (CDeclr),
                                                  CDerivedDeclarator (CPtrDeclr),
                                                  CExpression (CCast, CVar),
                                                  CInitializer (CInitExpr),
                                                  CStatement (CCompound), Ident,
                                                  NodeInfo)
import qualified Language.C                      as C
import           Language.C.Analysis.AstAnalysis (ExprSide (RValue), tExpr)
import           Language.C.Analysis.SemRep      (FunDef (..), FunType (..),
                                                  GlobalDecls, IdentDecl (..),
                                                  ParamDecl (..), Type (..),
                                                  VarDecl (..), VarName (..))
import           Language.C.Analysis.TravMonad   (Trav, TravT)
import           Language.C.Data.Ident           (Ident (Ident))
import           Prettyprinter                   (pretty, (<+>))
import           Tokstyle.C.Env                  (Env (params),
                                                  bracketUserState,
                                                  recordLinterError)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)

voidPtrParams :: [ParamDecl] -> [Ident]
voidPtrParams :: [ParamDecl] -> [Ident]
voidPtrParams = (ParamDecl -> Maybe Ident) -> [ParamDecl] -> [Ident]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ParamDecl -> Maybe Ident
isVoidPtr
  where
    isVoidPtr :: ParamDecl -> Maybe Ident
isVoidPtr (ParamDecl (VarDecl (VarName Ident
x Maybe AsmName
_) DeclAttrs
_ Type
TY_void_ptr) NodeInfo
_) = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
x
    isVoidPtr ParamDecl
_                                                   = Maybe Ident
forall a. Maybe a
Nothing


pattern VPtrCast :: CExpression a -> Ident -> CExpression a
pattern $mVPtrCast :: forall r a.
CExpression a -> (CExpression a -> Ident -> r) -> (Void# -> r) -> r
VPtrCast var ref <- (CCast (CDecl _ [(Just (CDeclr _ [CPtrDeclr [] _] _ [] _),_,_)] _) var@(CVar ref _) _)

pattern VParamCast :: Ident -> CCompoundBlockItem a
pattern $mVParamCast :: forall r a.
CCompoundBlockItem a -> (Ident -> r) -> (Void# -> r) -> r
VParamCast ref <- CBlockDecl (CDecl _ [(Just (CDeclr _ [CPtrDeclr _ _] _ [] _),Just (CInitExpr (VPtrCast _ ref) _),_)] _)

linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doIdentDecl :: IdentDecl -> TravT Env Identity () -> TravT Env Identity ()
doIdentDecl = \IdentDecl
node TravT Env Identity ()
act -> case IdentDecl
node of
        FunctionDef (FunDef (VarDecl (VarName Ident
fname Maybe AsmName
_) DeclAttrs
_ (FunctionType (FunType Type
_ [ParamDecl]
ps Bool
_) Attributes
_)) (CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
body NodeInfo
_) NodeInfo
_)
            | [Char]
"sys_" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Ident -> [Char]
idName Ident
fname -> () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise -> [Ident] -> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
checkFunction ([ParamDecl] -> [Ident]
voidPtrParams [ParamDecl]
ps) [CCompoundBlockItem NodeInfo]
body

        IdentDecl
_ -> TravT Env Identity ()
act

    , doExpr :: CExpr -> TravT Env Identity () -> TravT Env Identity ()
doExpr = \CExpr
node TravT Env Identity ()
act -> case CExpr
node of
        VPtrCast CExpr
e Ident
n -> do
            Type
dstTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
node
            Type
srcTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
            case Type
srcTy of
                Type
TY_void_ptr ->
                    NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
node) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                        Doc AnsiStyle
"first statement must cast" 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 (Doc AnsiStyle
"void *" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Ident -> [Char]
idName Ident
n)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"to" 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 a ann. Pretty a => a -> Doc ann
pretty (Doc -> [Char]
forall a. Show a => a -> [Char]
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
dstTy)))
                Type
_ -> () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        CExpr
_ -> TravT Env Identity ()
act
    }
  where
    idName :: Ident -> [Char]
idName (Ident [Char]
name Int
_ NodeInfo
_) = [Char]
name

    checkFunction :: [Ident] -> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
    checkFunction :: [Ident] -> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
checkFunction [] [CCompoundBlockItem NodeInfo]
_                    = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- ignore functions without vptr param
    checkFunction [Ident]
_ []                    = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- ignore empty functions
    checkFunction [Ident]
vptrs (VParamCast Ident
_:[CCompoundBlockItem NodeInfo]
ss) = [Ident] -> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
checkFunction [Ident]
vptrs [CCompoundBlockItem NodeInfo]
ss
    checkFunction [Ident]
vptrs [CCompoundBlockItem NodeInfo]
body              = [Ident] -> TravT Env Identity () -> TravT Env Identity ()
checkCastInit [Ident]
vptrs (AstActions (TravT Env Identity)
-> [CCompoundBlockItem NodeInfo] -> TravT Env Identity ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst AstActions (TravT Env Identity)
linter [CCompoundBlockItem NodeInfo]
body)

    checkCastInit :: [Ident] -> TravT Env Identity () -> TravT Env Identity ()
    checkCastInit :: [Ident] -> TravT Env Identity () -> TravT Env Identity ()
checkCastInit [Ident]
vptrs = (Env -> Env) -> TravT Env Identity () -> TravT Env Identity ()
forall a. (Env -> Env) -> Trav Env a -> Trav Env a
bracketUserState (\Env
env -> Env
env{params :: [Ident]
params = [Ident]
vptrs})


analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> TravT Env Identity ()
analyse = AstActions (TravT Env Identity)
-> GlobalDecls -> TravT Env Identity ()
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 -> TravT Env Identity (), (Text, Text))
descr = (GlobalDecls -> TravT Env Identity ()
analyse, (Text
"void-call", Text
"Checks that the first statement of a function with a `void*` parameter casts it to a specific type."))