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

import           Data.Functor.Identity           (Identity)
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemError    (typeMismatch)
import           Language.C.Analysis.SemRep      (GlobalDecls, Type (..))
import           Language.C.Analysis.TravMonad   (MonadTrav, Trav, TravT,
                                                  recordError)
import           Language.C.Analysis.TypeUtils   (canonicalType)
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)


-- | This catches `sizeof(buf)` where `buf` is a pointer instead of an array.
checkSizeof :: MonadTrav m => CExpr -> Type -> m ()
checkSizeof :: CExpr -> Type -> m ()
checkSizeof CExpr
_ (Type -> Type
canonicalType -> TY_struct String
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSizeof CExpr
_ (Type -> Type
canonicalType -> TY_struct_ptr String
"IPPTsPng") = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSizeof CExpr
_ ArrayType{} = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSizeof CExpr
e Type
ty
  | Type -> Bool
isIntegral Type
ty = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise =
      let annot :: (NodeInfo, Type)
annot = (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
e, Type
ty) in
      TypeMismatch -> m ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError (TypeMismatch -> m ()) -> TypeMismatch -> m ()
forall a b. (a -> b) -> a -> b
$ String -> (NodeInfo, Type) -> (NodeInfo, Type) -> TypeMismatch
typeMismatch
          (String
"disallowed sizeof argument of 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
ty) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
          String
"` - did you mean for `" 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
e) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` to be an array?") (NodeInfo, Type)
annot (NodeInfo, Type)
annot


linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doExpr :: CExpr -> TravT Env Identity () -> TravT Env Identity ()
doExpr = \CExpr
node TravT Env Identity ()
act -> case CExpr
node of
        CSizeofExpr CExpr
e NodeInfo
_ -> do
            Type
ty <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
            CExpr -> Type -> TravT Env Identity ()
forall (m :: * -> *). MonadTrav m => CExpr -> Type -> m ()
checkSizeof CExpr
e Type
ty
            TravT Env Identity ()
act

        CExpr
_ -> TravT Env Identity ()
act
    }


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