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

import           Data.Functor.Identity           (Identity)
import           Data.Maybe                      (mapMaybe)
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, recordError,
                                                  throwTravError)
import           Language.C.Pretty               (pretty)
import           Language.C.Syntax.AST           (CExpr, CExpression (..),
                                                  annotation)
import           Tokstyle.C.Env                  (Env)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)


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)]
_ ->
            let annot :: NodeInfo
annot = CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
expr in
            InvalidASTError -> Trav Env ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError (InvalidASTError -> Trav Env ()) -> InvalidASTError -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> InvalidASTError
invalidAST NodeInfo
annot (
                String
"parameter " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall a. Show a => a -> String
show (CExpr -> Doc
forall p. Pretty p => p -> Doc
pretty CExpr
expr) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is named `"
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`, but in callback type `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
cbTy) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` it is named `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`")
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