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

import           Data.Functor.Identity           (Identity)
import           Data.List                       (isSuffixOf)
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemError    (typeMismatch)
import           Language.C.Analysis.SemRep      (FunDef (..), FunType (..),
                                                  GlobalDecls, IdentDecl (..),
                                                  IntType (..), Type (..),
                                                  TypeName (..), VarDecl (..),
                                                  mergeTypeQuals, noTypeQuals)
import           Language.C.Analysis.TravMonad   (MonadTrav, Trav, TravT,
                                                  recordError)
import           Language.C.Analysis.TypeUtils   (canonicalType, sameType,
                                                  typeQualsUpd)
import           Language.C.Data.Node            (NodeInfo)
import           Language.C.Data.Position        (posFile, posOf)
import           Language.C.Pretty               (pretty)
import           Language.C.Syntax.AST           (Annotated, CAssignOp (..),
                                                  CExpr, CExpression (..),
                                                  CStatement (..), annotation)
import qualified Tokstyle.C.Env                  as Env
import           Tokstyle.C.Env                  (Env)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)

typeEq :: Type -> Type -> Bool
typeEq :: Type -> Type -> Bool
typeEq Type
a Type
b = Type -> Type -> Bool
sameType (Type -> Type
canon Type
a) (Type -> Type
canon Type
b)
  where
    canon :: Type -> Type
canon = Type -> Type
removeQuals (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
canonicalType

removeQuals :: Type -> Type
removeQuals :: Type -> Type
removeQuals = (TypeQuals -> TypeQuals) -> Type -> Type
typeQualsUpd (TypeQuals -> TypeQuals -> TypeQuals
mergeTypeQuals TypeQuals
noTypeQuals)

checkConversion :: (Annotated node, MonadTrav m) => String -> (CExpr, Type) -> (node NodeInfo, Type) -> m ()
-- Ignore cmp.c, it does a lot of implicit conversions.
-- TODO(iphydf): Maybe it shouldn't? UBSAN also warns about it.
checkConversion :: String -> (CExpr, Type) -> (node NodeInfo, Type) -> m ()
checkConversion String
_ (CExpr
r, Type
_) (node NodeInfo
_, Type
_) | String
"cmp/cmp.c" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Position -> String
posFile (NodeInfo -> Position
forall a. Pos a => a -> Position
posOf (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
r)) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkConversion String
_ (CExpr
_, Type
TY_void_ptr) (node NodeInfo
_, PtrType{}) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkConversion String
_ (CExpr
_, ArrayType{}) (node NodeInfo
_, PtrType{}) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkConversion String
_ (CExpr
_, Type
rTy) (node NodeInfo
_, Type
lTy)               | Type -> Type -> Bool
typeEq Type
lTy Type
rTy = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Allow int to enum conversion to cover ternary operator "?:". Only actual
-- "int" is allowed, not "int32_t" or anything typedef'd. The latter would mean
-- assignment from something that didn't undergo implicit int conversions.
checkConversion String
_ (CExpr
_, Type
rTy) (node NodeInfo
_, Type
lTy) | Type -> Type -> Bool
isEnumConversion (Type -> Type
canonicalType Type
lTy) Type
rTy = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    isEnumConversion :: Type -> Type -> Bool
isEnumConversion (DirectType TyEnum{} TypeQuals
_ Attributes
_) (DirectType (TyIntegral IntType
TyInt) TypeQuals
_ Attributes
_) = Bool
True
    isEnumConversion Type
_ Type
_ = Bool
False

checkConversion String
context (CExpr
r, Type -> Type
removeQuals -> Type
rTy) (node NodeInfo
l, Type -> Type
removeQuals -> Type
lTy) =
    case (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
rTy, Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall p. Pretty p => p -> Doc
pretty Type
lTy) of
      (String
rTyName, String
lTyName) | String
rTyName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lTyName -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"uint8_t [32]",String
"uint8_t const [32]") -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"char *",String
"const char *")         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"const int *",String
"const char *")    -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"void *")                      -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"const void *")                -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- int literals and integer promotions.
      (String
"int",String
_)                         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      (String
"uint32_t",String
"int64_t")            -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"enum RTPFlags",String
"uint64_t")      -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- TODO(iphydf): Almost definitely wrong (code should be fixed).
      (String
"unsigned long long",String
"uint16_t") -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"unsigned int",String
"uint16_t")       -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"uint32_t",String
"uint16_t")           -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
"uint8_t",String
"int8_t")              -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- TODO(iphydf): Look into these.
      (String
_,String
"uint8_t")                     -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"int32_t")                     -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"uint32_t")                    -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"size_t")                      -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"unsigned int")                -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"int")                         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
_,String
"long")                        -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- TODO(iphydf): Remove once the "system" PR is in.
      (String
"const struct Memory *",String
"Memory const *") -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      (String
rTyName, String
lTyName) ->
          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
"invalid conversion from `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rTyName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` to `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                  String
lTyName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
context)
              (node NodeInfo -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation node NodeInfo
l, Type
lTy)
              (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
r, Type
rTy)

checkAssign :: MonadTrav m => String -> (CExpr, Type) -> (CExpr, Type) -> m ()
checkAssign :: String -> (CExpr, Type) -> (CExpr, Type) -> m ()
checkAssign String
_ (CExpr, Type)
_ (CConst{}, Type
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAssign String
_ (CExpr, Type)
_ (CCast{}, Type
_)  = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAssign String
c (CExpr, Type)
l (CExpr, Type)
r             = String -> (CExpr, Type) -> (CExpr, Type) -> m ()
forall (node :: * -> *) (m :: * -> *).
(Annotated node, MonadTrav m) =>
String -> (CExpr, Type) -> (node NodeInfo, Type) -> m ()
checkConversion String
c (CExpr, Type)
r (CExpr, Type)
l


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
        CAssign CAssignOp
CAssignOp CExpr
l CExpr
r NodeInfo
_ -> do
            Type
lTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
LValue CExpr
l
            Type
rTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
r
            String -> (CExpr, Type) -> (CExpr, Type) -> TravT Env Identity ()
forall (m :: * -> *).
MonadTrav m =>
String -> (CExpr, Type) -> (CExpr, Type) -> m ()
checkAssign String
"assignment" (CExpr
l, Type
lTy) (CExpr
r, Type
rTy)
        CExpr
_ -> TravT Env Identity ()
act

    , doStat :: CStat -> TravT Env Identity () -> TravT Env Identity ()
doStat = \CStat
node TravT Env Identity ()
act -> case CStat
node of
        CReturn (Just CExpr
expr) NodeInfo
_ -> do
            Type
retTy <- TravT Env Identity Type
Env.getRetTy
            Type
exprTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
expr
            String -> (CExpr, Type) -> (CExpr, Type) -> TravT Env Identity ()
forall (node :: * -> *) (m :: * -> *).
(Annotated node, MonadTrav m) =>
String -> (CExpr, Type) -> (node NodeInfo, Type) -> m ()
checkConversion String
"return" (CExpr
expr, Type
exprTy) (CExpr
expr, Type
retTy)
            TravT Env Identity ()
act
        CStat
_ -> TravT Env Identity ()
act

    , doIdentDecl :: IdentDecl -> TravT Env Identity () -> TravT Env Identity ()
doIdentDecl = \IdentDecl
node TravT Env Identity ()
act -> case IdentDecl
node of
        FunctionDef (FunDef (VarDecl VarName
_ DeclAttrs
_ (FunctionType (FunType Type
ty [ParamDecl]
_ Bool
_) Attributes
_)) CStat
_ NodeInfo
_) -> do
            Type -> TravT Env Identity ()
Env.setRetTy Type
ty
            TravT Env Identity ()
act
            TravT Env Identity ()
Env.unsetRetTy
        IdentDecl
_ -> 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