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

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

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 ->
                    InvalidASTError -> TravT Env Identity ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError (InvalidASTError -> TravT Env Identity ())
-> InvalidASTError -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> [Char] -> InvalidASTError
invalidAST (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
node) ([Char] -> InvalidASTError) -> [Char] -> InvalidASTError
forall a b. (a -> b) -> a -> b
$
                        [Char]
"first statement must cast `void *" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Ident -> [Char]
idName Ident
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"` to `" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Doc -> [Char]
forall a. Show a => a -> [Char]
show (Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
dstTy) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"`"
                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 s a. (s -> s) -> Trav s a -> Trav s 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