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

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

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) => String -> (CExpr, Type) -> (node NodeInfo, Type) -> TravT Env Identity ()
-- 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) -> TravT Env Identity ()
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)) = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkConversion String
context (CExpr
r, Type
rTy') (node NodeInfo
_, Type
lTy') =
    Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isAllowed (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
        NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
r) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle
"invalid conversion from" 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 (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
rTyName) 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 (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
lTyName) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"in" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
context
  where
    rTy :: Type
rTy = Type -> Type
removeQuals Type
rTy'
    lTy :: Type
lTy = Type -> Type
removeQuals Type
lTy'
    rCanon :: Type
rCanon = Type -> Type
canonicalType Type
rTy
    lCanon :: Type
lCanon = Type -> Type
canonicalType Type
lTy
    rTyName :: String
rTyName = 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
C.pretty Type
rTy
    lTyName :: String
lTyName = 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
C.pretty Type
lTy

    isAllowed :: Bool
isAllowed =
        Type -> Bool
isNullPtr Type
rTy'
        Bool -> Bool -> Bool
|| Type -> Type -> Bool
typeEq Type
lTy Type
rTy
        Bool -> Bool -> Bool
|| Type -> Type -> Bool
sameType Type
rCanon Type
lCanon
        Bool -> Bool -> Bool
|| Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
rCanon) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
lCanon)
        Bool -> Bool -> Bool
|| case (Type
rCanon, Type
lCanon) of
            (PtrType Type
rPtd TypeQuals
_ Attributes
_, PtrType Type
lPtd TypeQuals
_ Attributes
_) ->
                Type -> Type -> Bool
typeEq Type
lPtd Type
rPtd Bool -> Bool -> Bool
|| Type -> Bool
isVoidPtr Type
lCanon
            (ArrayType Type
rPtd ArraySize
_ TypeQuals
_ Attributes
_, PtrType Type
lPtd TypeQuals
_ Attributes
_) ->
                Type -> Type -> Bool
typeEq Type
lPtd Type
rPtd Bool -> Bool -> Bool
|| Type -> Bool
isVoidPtr Type
lCanon
            (Type, Type)
_ -> Type -> Type -> Bool
isEnumConversion Type
lCanon Type
rTy' Bool -> Bool -> Bool
|| Bool
special

    isNullPtr :: Type -> Bool
isNullPtr Type
TY_nullptr = Bool
True
    isNullPtr Type
_          = Bool
False

    isEnumConversion :: Type -> Type -> Bool
isEnumConversion (DirectType TyEnum{} TypeQuals
_ Attributes
_) (DirectType (TyIntegral IntType
TyInt) TypeQuals
_ Attributes
_) = Bool
True
    isEnumConversion Type
_ Type
_ = Bool
False

    isVoidPtr :: Type -> Bool
isVoidPtr Type
TY_void_ptr = Bool
True
    isVoidPtr Type
_           = Bool
False

    special :: Bool
special = case (String
rTyName, String
lTyName) of
      (String
"uint8_t [32]",String
"uint8_t const [32]") -> Bool
True
      (String
"const int *",String
"const char *")        -> Bool
True
      (String
"char *",String
"const char *")             -> Bool
True

      -- int literals and integer promotions.
      (String
"int",String
_) | Bool -> Bool
not (Type -> Bool
isPtr Type
lTy)           -> Bool
True

      (String
"uint32_t",String
"int64_t")                -> Bool
True
      (String
"enum RTPFlags",String
"uint64_t")          -> Bool
True

      -- TODO(iphydf): Almost definitely wrong (code should be fixed).
      (String
"unsigned long long",String
"uint16_t")     -> Bool
True
      (String
"unsigned int",String
"uint16_t")           -> Bool
True
      (String
"uint32_t",String
"uint16_t")               -> Bool
True
      (String
"uint8_t",String
"int8_t")                  -> Bool
True

      -- TODO(iphydf): Look into these.
      (String
_,String
"uint8_t")                         -> Bool
True
      (String
_,String
"int32_t")                         -> Bool
True
      (String
_,String
"uint32_t")                        -> Bool
True
      (String
_,String
"size_t")                          -> Bool
True
      (String
_,String
"unsigned int")                    -> Bool
True
      (String
_,String
"int")                             -> Bool
True
      (String
_,String
"long")                            -> Bool
True
      (String, String)
_                                     -> Bool
False

    isPtr :: Type -> Bool
isPtr PtrType{}   = Bool
True
    isPtr ArrayType{} = Bool
True
    isPtr Type
_           = Bool
False

checkAssign :: String -> (CExpr, Type) -> (CExpr, Type) -> TravT Env Identity ()
checkAssign :: String -> (CExpr, Type) -> (CExpr, Type) -> TravT Env Identity ()
checkAssign String
_ (CExpr, Type)
_ (CConst{}, Type
_) = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAssign String
_ (CExpr, Type)
_ (CCast{}, Type
_)  = () -> TravT Env Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkAssign String
c (CExpr, Type)
l (CExpr, Type)
r             = String -> (CExpr, Type) -> (CExpr, Type) -> TravT Env Identity ()
forall (node :: * -> *).
Annotated node =>
String
-> (CExpr, Type) -> (node NodeInfo, Type) -> TravT Env Identity ()
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 ()
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 :: * -> *).
Annotated node =>
String
-> (CExpr, Type) -> (node NodeInfo, Type) -> TravT Env Identity ()
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


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> TravT Env Identity (), (Text, Text))
descr = (GlobalDecls -> TravT Env Identity ()
analyse, (Text
"conversion", Text
"Checks for disallowed implicit conversions."))