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

import           Data.Functor.Identity           (Identity)
import           Data.List                       (find, intercalate, isInfixOf,
                                                  zip4)
import           Data.Map.Strict                 (Map)
import qualified Data.Map.Strict                 as Map
import           Data.Maybe                      (mapMaybe)
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import qualified Data.Text.IO                    as Text
import qualified Data.Text.Lazy                  as TL
import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemError    (typeMismatch)
import           Language.C.Analysis.SemRep      (CompType (..),
                                                  CompTypeRef (..),
                                                  EnumType (..),
                                                  EnumTypeRef (..),
                                                  Enumerator (..), FunDef (..),
                                                  FunType (..),
                                                  GlobalDecls (..),
                                                  IdentDecl (..),
                                                  MemberDecl (..), ObjDef (..),
                                                  ParamDecl (..), TagDef (..),
                                                  Type (..), TypeDef (..),
                                                  TypeDefRef (..),
                                                  TypeName (..), TypeQuals (..),
                                                  VarDecl (..), VarName (..),
                                                  noTypeQuals)
import           Language.C.Analysis.TravMonad   (Trav, TravT, getUserState,
                                                  modifyUserState)
import           Language.C.Analysis.TypeUtils   (canonicalType, sameType)
import           Language.C.Data.Ident           (Ident (Ident),
                                                  SUERef (AnonymousRef, NamedRef))
import           Language.C.Data.Node            (NodeInfo (..), nodeInfo,
                                                  posOfNode)
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST
import           Language.C.Syntax.Constants     (CInteger (..))
import           Prettyprinter                   (Doc, annotate, line, nest,
                                                  pretty, vsep, (<+>))
import           Prettyprinter.Render.Terminal   (AnsiStyle, Color (..), bold,
                                                  color, colorDull)
import           Tokstyle.C.Env                  (DiagnosticLevel (..),
                                                  DiagnosticSpan (..),
                                                  Env (globalDecls, mainTypedefs, retTy),
                                                  posAndLen, recordRichError)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)


-- | Get the name of an identifier.
idName :: Ident -> String
idName :: Ident -> String
idName (Ident String
name Int
_ NodeInfo
_) = String
name


isStandardType :: String -> Bool
isStandardType :: String -> Bool
isStandardType String
name = String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
    [ String
"uint8_t", String
"uint16_t", String
"uint32_t", String
"uint64_t"
    , String
"int8_t", String
"int16_t", String
"int32_t", String
"int64_t"
    , String
"size_t", String
"ssize_t", String
"uintptr_t", String
"intptr_t", String
"ptrdiff_t"
    , String
"int_least8_t", String
"int_least16_t", String
"int_least32_t", String
"int_least64_t"
    , String
"uint_least8_t", String
"uint_least16_t", String
"uint_least32_t", String
"uint_least64_t"
    , String
"int_fast8_t", String
"int_fast16_t", String
"int_fast32_t", String
"int_fast64_t"
    , String
"uint_fast8_t", String
"uint_fast16_t", String
"uint_fast32_t", String
"uint_fast64_t"
    , String
"intmax_t", String
"uintmax_t"
    , String
"bool", String
"_Bool", String
"nullptr_t", String
"va_list"
    , String
"__uint8_t", String
"__uint16_t", String
"__uint32_t", String
"__uint64_t"
    , String
"__int8_t", String
"__int16_t", String
"__int32_t", String
"__int64_t"
    , String
"__size_t", String
"__ssize_t", String
"__uintptr_t", String
"__intptr_t", String
"__ptrdiff_t"
    , String
"__off_t", String
"__off64_t", String
"__time_t", String
"__suseconds_t"
    , String
"__builtin_va_list", String
"socklen_t", String
"__socklen_t"
    , String
"opus_int16", String
"opus_int32"
    ]


-- | A simplified representation of a type for strictness analysis.
data Essence
    = Estrict Ident Essence
    | Estandard String
    | Eptr Essence
    | Earray Essence
    | Efunction Essence [(Maybe String, Essence)]
    | Ecomp SUERef
    | Eenum SUERef
    | Ebuiltin String
    | Evoid
    | Eanonymous
    deriving (Int -> Essence -> ShowS
[Essence] -> ShowS
Essence -> String
(Int -> Essence -> ShowS)
-> (Essence -> String) -> ([Essence] -> ShowS) -> Show Essence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Essence] -> ShowS
$cshowList :: [Essence] -> ShowS
show :: Essence -> String
$cshow :: Essence -> String
showsPrec :: Int -> Essence -> ShowS
$cshowsPrec :: Int -> Essence -> ShowS
Show, Essence -> Essence -> Bool
(Essence -> Essence -> Bool)
-> (Essence -> Essence -> Bool) -> Eq Essence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Essence -> Essence -> Bool
$c/= :: Essence -> Essence -> Bool
== :: Essence -> Essence -> Bool
$c== :: Essence -> Essence -> Bool
Eq)


-- | Convert a C type to its Essence.
toEssence :: Type -> Essence
toEssence :: Type -> Essence
toEssence Type
ty = case Type
ty of
    TypeDefType (TypeDefRef Ident
ident Type
_ NodeInfo
_) TypeQuals
_ Attributes
_
        | String -> Bool
isStandardType (Ident -> String
idName Ident
ident) -> String -> Essence
Estandard (Ident -> String
idName Ident
ident)
        | Bool
otherwise -> Ident -> Essence -> Essence
Estrict Ident
ident (Type -> Essence
toEssence (Type -> Type
canonicalType Type
ty))
    PtrType Type
t TypeQuals
_ Attributes
_ -> Essence -> Essence
Eptr (Type -> Essence
toEssence Type
t)
    ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
_ -> Essence -> Essence
Earray (Type -> Essence
toEssence Type
t)
    FunctionType (FunType Type
r [ParamDecl]
ps Bool
_) Attributes
_ ->
        Essence -> [(Maybe String, Essence)] -> Essence
Efunction (Type -> Essence
toEssence Type
r) ((ParamDecl -> (Maybe String, Essence))
-> [ParamDecl] -> [(Maybe String, Essence)]
forall a b. (a -> b) -> [a] -> [b]
map ParamDecl -> (Maybe String, Essence)
getParamInfo [ParamDecl]
ps)
    DirectType (TyComp (CompTypeRef SUERef
ref CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ ->
        case SUERef
ref of
            AnonymousRef Name
_ -> Essence
Eanonymous
            SUERef
_              -> SUERef -> Essence
Ecomp SUERef
ref
    DirectType (TyEnum (EnumTypeRef SUERef
ref NodeInfo
_)) TypeQuals
_ Attributes
_ ->
        case SUERef
ref of
            AnonymousRef Name
_ -> Essence
Eanonymous
            SUERef
_              -> SUERef -> Essence
Eenum SUERef
ref
    DirectType TypeName
TyVoid TypeQuals
_ Attributes
_ -> Essence
Evoid
    DirectType TypeName
t TypeQuals
_ Attributes
_ -> String -> Essence
Estandard (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty (TypeName -> TypeQuals -> Attributes -> Type
DirectType TypeName
t TypeQuals
noTypeQuals [])))
    Type
_ -> String -> Essence
Ebuiltin (Doc -> String
forall a. Show a => a -> String
show (Type -> Doc
forall p. Pretty p => p -> Doc
C.pretty Type
ty))
  where
    getParamInfo :: ParamDecl -> (Maybe String, Essence)
getParamInfo (ParamDecl (VarDecl VarName
name DeclAttrs
_ Type
t) NodeInfo
_)         = (VarName -> Maybe String
getName VarName
name, Type -> Essence
toEssence Type
t)
    getParamInfo (AbstractParamDecl (VarDecl VarName
name DeclAttrs
_ Type
t) NodeInfo
_) = (VarName -> Maybe String
getName VarName
name, Type -> Essence
toEssence Type
t)

    getName :: VarName -> Maybe String
getName (VarName (Ident String
n Int
_ NodeInfo
_) Maybe AsmName
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
    getName VarName
_                         = Maybe String
forall a. Maybe a
Nothing


-- | Check if an essence is a function or a function pointer.
isFunctionEssence :: Essence -> Bool
isFunctionEssence :: Essence -> Bool
isFunctionEssence = \case
    Efunction {} -> Bool
True
    Eptr Essence
e       -> Essence -> Bool
isFunctionEssence Essence
e
    Estrict Ident
_ Essence
e  -> Essence -> Bool
isFunctionEssence Essence
e
    Essence
_            -> Bool
False


data PathSegment
    = InReturn
    | InParam Int (Maybe String)
    | InPointer
    | InArray
    | InVariable String
    deriving (PathSegment -> PathSegment -> Bool
(PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool) -> Eq PathSegment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathSegment -> PathSegment -> Bool
$c/= :: PathSegment -> PathSegment -> Bool
== :: PathSegment -> PathSegment -> Bool
$c== :: PathSegment -> PathSegment -> Bool
Eq, Int -> PathSegment -> ShowS
[PathSegment] -> ShowS
PathSegment -> String
(Int -> PathSegment -> ShowS)
-> (PathSegment -> String)
-> ([PathSegment] -> ShowS)
-> Show PathSegment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathSegment] -> ShowS
$cshowList :: [PathSegment] -> ShowS
show :: PathSegment -> String
$cshow :: PathSegment -> String
showsPrec :: Int -> PathSegment -> ShowS
$cshowsPrec :: Int -> PathSegment -> ShowS
Show)


type Path = [PathSegment]


describePath :: Path -> String
describePath :: [PathSegment] -> String
describePath [] = String
""
describePath (PathSegment
s:[PathSegment]
ss) = case PathSegment
s of
    PathSegment
InReturn           -> String
"the return value" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
    InParam Int
i (Just String
n) -> String
"argument " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ('" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"')" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
    InParam Int
i Maybe String
Nothing  -> String
"argument " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
    PathSegment
InPointer          -> String
"pointer" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
    PathSegment
InArray            -> String
"array" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
    InVariable String
n       -> String
"variable '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
  where
    rest :: String
rest = if [PathSegment] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PathSegment]
ss then String
"" else String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [PathSegment] -> String
describePath [PathSegment]
ss


prettyEssence :: Essence -> Doc AnsiStyle
prettyEssence :: Essence -> Doc AnsiStyle
prettyEssence = \case
    Estrict Ident
i Essence
e        -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Blue AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Ident -> String
idName Ident
i)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
colorDull Color
White) (Doc AnsiStyle
"(aka" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
e Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
")")
    Estandard String
s        -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
s)
    Eptr Essence
e             -> Essence -> Doc AnsiStyle
prettyEssence Essence
e Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"*"
    Earray Essence
e           -> Essence -> Doc AnsiStyle
prettyEssence Essence
e Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"[]"
    Efunction Essence
r [(Maybe String, Essence)]
ps     -> Essence -> Doc AnsiStyle
prettyEssence Essence
r Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"(" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat (Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
intercalateDoc Doc AnsiStyle
", " (((Maybe String, Essence) -> Doc AnsiStyle)
-> [(Maybe String, Essence)] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (Essence -> Doc AnsiStyle
prettyEssence (Essence -> Doc AnsiStyle)
-> ((Maybe String, Essence) -> Essence)
-> (Maybe String, Essence)
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, Essence) -> Essence
forall a b. (a, b) -> b
snd) [(Maybe String, Essence)]
ps)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
")"
    Ecomp (NamedRef Ident
i) -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta) Doc AnsiStyle
"struct" 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 (Ident -> String
idName Ident
i)
    Eenum (NamedRef Ident
i) -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta) Doc AnsiStyle
"enum" 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 (Ident -> String
idName Ident
i)
    Ecomp SUERef
_            -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta) Doc AnsiStyle
"struct" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"<anonymous>"
    Eenum SUERef
_            -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Magenta) Doc AnsiStyle
"enum" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"<anonymous>"
    Ebuiltin String
s         -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
s)
    Essence
Evoid              -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) Doc AnsiStyle
"void"
    Essence
Eanonymous         -> Doc AnsiStyle
"<anonymous>"
  where
    intercalateDoc :: a -> [a] -> [a]
intercalateDoc a
_ []       = []
    intercalateDoc a
_ [a
x]      = [a
x]
    intercalateDoc a
sep (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
sep a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
intercalateDoc a
sep [a]
xs


prettyEssenceBrief :: Essence -> Doc AnsiStyle
prettyEssenceBrief :: Essence -> Doc AnsiStyle
prettyEssenceBrief = \case
    Estrict Ident
i Essence
_ -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Blue AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (Ident -> String
idName Ident
i))
    Essence
e           -> Essence -> Doc AnsiStyle
prettyEssence Essence
e


-- | Match mode for strict typedefs.
data MatchMode = Strict | Lenient | Cast


data Mismatch = Mismatch
    { Mismatch -> Essence
mismatchRootExpected :: Essence
    , Mismatch -> Essence
mismatchRootActual   :: Essence
    , Mismatch -> [PathSegment]
mismatchPath         :: Path
    , Mismatch -> Essence
mismatchDeepExpected :: Essence
    , Mismatch -> Essence
mismatchDeepActual   :: Essence
    }


recordMismatch :: NodeInfo -> Mismatch -> Trav Env ()
recordMismatch :: NodeInfo -> Mismatch -> Trav Env ()
recordMismatch NodeInfo
info (Mismatch Essence
rootExpected Essence
rootActual [PathSegment]
path Essence
expected Essence
actual) =
    NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Trav Env ()
recordRichError NodeInfo
info DiagnosticLevel
ErrorLevel Doc AnsiStyle
msg [DiagnosticSpan Position]
spans [(DiagnosticLevel, Doc AnsiStyle)]
footer
  where
    (Position
pos, Int
len) = NodeInfo -> (Position, Int)
posAndLen NodeInfo
info

    isCallbackMismatch :: Bool
isCallbackMismatch =
        let e1 :: Essence
e1 = Essence -> Essence
strip Essence
rootExpected
            e2 :: Essence
e2 = Essence -> Essence
strip Essence
rootActual
        in case (Essence
e1, Essence
e2) of
            (Estrict Ident
_ Essence
f1, Estrict Ident
_ Essence
f2) -> Essence -> Bool
isFunctionEssence Essence
f1 Bool -> Bool -> Bool
&& Essence -> Bool
isFunctionEssence Essence
f2
            (Essence, Essence)
_                            -> Bool
False
      where
        strip :: Essence -> Essence
strip (Eptr Essence
e)      = Essence -> Essence
strip Essence
e
        strip (Estrict Ident
i Essence
e) = Ident -> Essence -> Essence
Estrict Ident
i Essence
e -- Keep the outermost strict wrapper
        strip Essence
e             = Essence
e

    isDeepMismatch :: Bool
isDeepMismatch = case Int -> [PathSegment] -> [PathSegment]
forall a. Int -> [a] -> [a]
drop Int
1 [PathSegment]
path of
        [] -> Bool
False
        [PathSegment]
ss -> (PathSegment -> Bool) -> [PathSegment] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case InParam{} -> Bool
True; PathSegment
InReturn -> Bool
True; PathSegment
_ -> Bool
False) [PathSegment]
ss

    msg :: Doc AnsiStyle
msg | Bool
isCallbackMismatch = Doc AnsiStyle
"incompatible callback role"
        | Bool
isDeepMismatch = case [PathSegment]
path of
            (InParam Int
_ Maybe String
outerName : [PathSegment]
_) ->
                Doc AnsiStyle
"incompatible callback type for parameter" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
-> (String -> Doc AnsiStyle) -> Maybe String -> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle
"callback" (\String
n -> Doc AnsiStyle
"'" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
n Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"'") Maybe String
outerName
            [PathSegment]
_ -> Doc AnsiStyle
"strict typedef mismatch"
        | Bool
otherwise = case [PathSegment]
path of
            (PathSegment
InReturn:[PathSegment]
_) ->
                Doc AnsiStyle
"returning" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
actual Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"from a function expecting" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
expected
            (InParam Int
_ Maybe String
n:[PathSegment]
_) ->
                Doc AnsiStyle
"passing" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
actual Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"to parameter" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
-> (String -> Doc AnsiStyle) -> Maybe String -> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle
forall a. Monoid a => a
mempty (\String
name -> Doc AnsiStyle
"'" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
name Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"'") Maybe String
n Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"of type" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
expected
            (InVariable String
n:[PathSegment]
_) ->
                Doc AnsiStyle
"assigning" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
actual Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"to variable" 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
n) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"of type" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
expected
            [PathSegment]
_ ->
                Doc AnsiStyle
"strict typedef mismatch"

    spans :: [DiagnosticSpan Position]
spans = [ Position -> Int -> [Doc AnsiStyle] -> DiagnosticSpan Position
forall pos. pos -> Int -> [Doc AnsiStyle] -> DiagnosticSpan pos
DiagnosticSpan Position
pos Int
len [Doc AnsiStyle]
labels ]
    labels :: [Doc AnsiStyle]
labels = if Bool
isDeepMismatch
             then [ Doc AnsiStyle
"expected" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssenceBrief Essence
rootExpected
                  , Doc AnsiStyle
"   found" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
rootActual
                  ]
             else [ Doc AnsiStyle
"expected" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
expected
                  , Doc AnsiStyle
"   found" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
actual
                  ]

    deepNote :: [(DiagnosticLevel, Doc AnsiStyle)]
deepNote = case [PathSegment]
path of
        (PathSegment
_ : [PathSegment]
rest) | Bool
isDeepMismatch ->
            [ (DiagnosticLevel
NoteLevel, Doc AnsiStyle
"mismatch 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 ([PathSegment] -> String
describePath [PathSegment]
rest) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<>
                          Doc AnsiStyle
"   expected" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
expected Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<>
                          Doc AnsiStyle
"      found" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Essence -> Doc AnsiStyle
prettyEssence Essence
actual) ]
        [PathSegment]
_ -> []

    footer :: [(DiagnosticLevel, Doc AnsiStyle)]
footer = [(DiagnosticLevel, Doc AnsiStyle)]
deepNote [(DiagnosticLevel, Doc AnsiStyle)]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> [(DiagnosticLevel, Doc AnsiStyle)]
forall a. [a] -> [a] -> [a]
++
        [ (DiagnosticLevel
NoteLevel, Doc AnsiStyle
"strict typedefs prevent accidental mixing of logically distinct types")
        , (DiagnosticLevel
HelpLevel, Doc AnsiStyle
"if this is intentional, use an explicit cast")
        ]


-- | Match two essences according to strict typedef rules.
matchEssence :: Map SUERef Ident -> MatchMode -> Path -> Essence -> Essence -> [Mismatch]
matchEssence :: Map SUERef Ident
-> MatchMode -> [PathSegment] -> Essence -> Essence -> [Mismatch]
matchEssence Map SUERef Ident
mains MatchMode
mode [PathSegment]
initialPath Essence
rootExpected Essence
rootActual = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
initialPath Essence
rootExpected Essence
rootActual
  where
    isMain :: Ident -> Essence -> Bool
isMain Ident
i = \case
        Ecomp SUERef
ref   -> SUERef -> Map SUERef Ident -> Maybe Ident
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SUERef
ref Map SUERef Ident
mains Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
i
        Eenum SUERef
ref   -> SUERef -> Map SUERef Ident -> Maybe Ident
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SUERef
ref Map SUERef Ident
mains Maybe Ident -> Maybe Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
i
        Estrict Ident
_ Essence
e -> Ident -> Essence -> Bool
isMain Ident
i Essence
e
        Essence
_           -> Bool
False

    isEstandardOrEnum :: Essence -> Bool
isEstandardOrEnum (Estandard String
_) = Bool
True
    isEstandardOrEnum (Eenum SUERef
_)     = Bool
True
    isEstandardOrEnum Essence
Eanonymous    = Bool
True
    isEstandardOrEnum Essence
_             = Bool
False

    isNullptr :: Essence -> Bool
isNullptr = \case
        Estandard String
"nullptr_t" -> Bool
True
        Estrict Ident
_ Essence
e           -> Essence -> Bool
isNullptr Essence
e
        Essence
_                     -> Bool
False

    mkMismatch :: [PathSegment] -> Essence -> Essence -> [Mismatch]
mkMismatch [PathSegment]
path Essence
expected Essence
actual = [Mismatch :: Essence
-> Essence -> [PathSegment] -> Essence -> Essence -> Mismatch
Mismatch
        { mismatchRootExpected :: Essence
mismatchRootExpected = Essence
rootExpected
        , mismatchRootActual :: Essence
mismatchRootActual = Essence
rootActual
        , mismatchPath :: [PathSegment]
mismatchPath = [PathSegment]
path
        , mismatchDeepExpected :: Essence
mismatchDeepExpected = Essence
expected
        , mismatchDeepActual :: Essence
mismatchDeepActual = Essence
actual
        }]

    go :: [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path (Estrict Ident
i1 Essence
e1) (Estrict Ident
i2 Essence
e2)
        | Ident -> String
idName Ident
i1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> String
idName Ident
i2 = []
        | Essence -> Bool
isNullptr Essence
e2 = []
        | MatchMode
Lenient <- MatchMode
mode = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e1 Essence
e2
        | Bool
otherwise = [PathSegment] -> Essence -> Essence -> [Mismatch]
mkMismatch [PathSegment]
path (Ident -> Essence -> Essence
Estrict Ident
i1 Essence
e1) (Ident -> Essence -> Essence
Estrict Ident
i2 Essence
e2)

    go [PathSegment]
path (Estrict Ident
i1 Essence
e1) Essence
a
        | Essence -> Bool
isFunctionEssence Essence
e1 Bool -> Bool -> Bool
&& Essence -> Bool
isFunctionEssence Essence
a = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e1 Essence
a
        | Essence
a Essence -> Essence -> Bool
forall a. Eq a => a -> a -> Bool
== Essence
Eanonymous = []
        | Essence -> Bool
isNullptr Essence
a = []
        | Essence
Evoid <- Essence
a, PathSegment
InPointer PathSegment -> [PathSegment] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PathSegment]
path = []
        | Ident -> Essence -> Bool
isMain Ident
i1 Essence
a = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e1 Essence
a
        | MatchMode
Lenient <- MatchMode
mode = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e1 Essence
a
        | MatchMode
Cast <- MatchMode
mode, Essence
e1 Essence -> Essence -> Bool
forall a. Eq a => a -> a -> Bool
== Essence
a = []
        | MatchMode
Cast <- MatchMode
mode, Essence -> Bool
isEstandardOrEnum Essence
e1, Essence -> Bool
isEstandardOrEnum Essence
a = []
        | Bool
otherwise = [PathSegment] -> Essence -> Essence -> [Mismatch]
mkMismatch [PathSegment]
path (Ident -> Essence -> Essence
Estrict Ident
i1 Essence
e1) Essence
a

    go [PathSegment]
path Essence
e (Estrict Ident
_ Essence
a2) = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e Essence
a2 -- ALLOW generic to strict

    go [PathSegment]
path (Eptr Essence
e1) (Eptr Essence
a1) = [PathSegment] -> Essence -> Essence -> [Mismatch]
go ([PathSegment]
path [PathSegment] -> [PathSegment] -> [PathSegment]
forall a. [a] -> [a] -> [a]
++ [PathSegment
InPointer]) Essence
e1 Essence
a1
    go [PathSegment]
path (Eptr Essence
e1) Essence
a | Essence -> Bool
isFunctionEssence Essence
a = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e1 Essence
a -- decay
    go [PathSegment]
path Essence
e (Eptr Essence
a1) | Essence -> Bool
isFunctionEssence Essence
e = [PathSegment] -> Essence -> Essence -> [Mismatch]
go [PathSegment]
path Essence
e Essence
a1 -- decay

    go [PathSegment]
path (Earray Essence
e1) (Earray Essence
a1) = [PathSegment] -> Essence -> Essence -> [Mismatch]
go ([PathSegment]
path [PathSegment] -> [PathSegment] -> [PathSegment]
forall a. [a] -> [a] -> [a]
++ [PathSegment
InArray]) Essence
e1 Essence
a1

    go [PathSegment]
path (Efunction Essence
r1 [(Maybe String, Essence)]
p1) (Efunction Essence
r2 [(Maybe String, Essence)]
p2) =
        [PathSegment] -> Essence -> Essence -> [Mismatch]
go ([PathSegment]
path [PathSegment] -> [PathSegment] -> [PathSegment]
forall a. [a] -> [a] -> [a]
++ [PathSegment
InReturn]) Essence
r1 Essence
r2 [Mismatch] -> [Mismatch] -> [Mismatch]
forall a. [a] -> [a] -> [a]
++
        ((Int, ((Maybe String, Essence), (Maybe String, Essence)))
 -> [Mismatch])
-> [(Int, ((Maybe String, Essence), (Maybe String, Essence)))]
-> [Mismatch]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int
i, ((Maybe String
n1, Essence
eP), (Maybe String
_, Essence
aP))) -> [PathSegment] -> Essence -> Essence -> [Mismatch]
go ([PathSegment]
path [PathSegment] -> [PathSegment] -> [PathSegment]
forall a. [a] -> [a] -> [a]
++ [Int -> Maybe String -> PathSegment
InParam Int
i Maybe String
n1]) Essence
eP Essence
aP) ([Int]
-> [((Maybe String, Essence), (Maybe String, Essence))]
-> [(Int, ((Maybe String, Essence), (Maybe String, Essence)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([(Maybe String, Essence)]
-> [(Maybe String, Essence)]
-> [((Maybe String, Essence), (Maybe String, Essence))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe String, Essence)]
p1 [(Maybe String, Essence)]
p2))

    go [PathSegment]
_ Essence
_ Essence
_ = []


checkStrictMatch :: MatchMode -> Path -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch :: MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
_ [PathSegment]
_ Type
_ Type
_ (CConst (CIntConst CInteger{} NodeInfo
_)) = () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkStrictMatch MatchMode
mode [PathSegment]
path Type
expected Type
actual CExpr
expr = do
    Map SUERef Ident
mains <- Env -> Map SUERef Ident
mainTypedefs (Env -> Map SUERef Ident)
-> TravT Env Identity Env -> TravT Env Identity (Map SUERef Ident)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TravT Env Identity Env
forall s. Trav s s
getUserState
    case Map SUERef Ident
-> MatchMode -> [PathSegment] -> Essence -> Essence -> [Mismatch]
matchEssence Map SUERef Ident
mains MatchMode
mode [PathSegment]
path (Type -> Essence
toEssence Type
expected) (Type -> Essence
toEssence Type
actual) of
        []   -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [Mismatch]
errs -> (Mismatch -> Trav Env ()) -> [Mismatch] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeInfo -> Mismatch -> Trav Env ()
recordMismatch (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
expr)) [Mismatch]
errs


linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doIdentDecl :: IdentDecl -> Trav Env () -> Trav Env ()
doIdentDecl = \IdentDecl
node Trav Env ()
act -> case IdentDecl
node of
        FunctionDef (FunDef (VarDecl VarName
_ DeclAttrs
_ (FunctionType (FunType Type
ty [ParamDecl]
_ Bool
_) Attributes
_)) Stmt
_ NodeInfo
_) -> do
            (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{retTy :: Maybe Type
retTy = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty}
            Trav Env ()
act
            (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{retTy :: Maybe Type
retTy = Maybe Type
forall a. Maybe a
Nothing}
        ObjectDef (ObjDef (VarDecl VarName
_ DeclAttrs
_ Type
expected) (Just Initializer
initializer) NodeInfo
_) -> do
            MatchMode -> Type -> Initializer -> Trav Env ()
checkInitializer MatchMode
Strict Type
expected Initializer
initializer
            Trav Env ()
act
        IdentDecl
_ -> Trav Env ()
act

    , doExpr :: CExpr -> Trav Env () -> Trav Env ()
doExpr = \CExpr
node Trav Env ()
act -> case CExpr
node of
        CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_ -> do
            Type
castTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
node
            Type
exprTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
            MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
Cast [] Type
castTy Type
exprTy CExpr
e
            Trav Env ()
act
        CCompoundLit CDeclaration NodeInfo
_ CInitializerList NodeInfo
initializer NodeInfo
_ -> do
            [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
node TravT Env Identity Type -> (Type -> Trav Env ()) -> Trav Env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type
expected ->
                MatchMode -> Type -> Initializer -> Trav Env ()
checkInitializer MatchMode
Lenient Type
expected (CInitializerList NodeInfo -> NodeInfo -> Initializer
forall a. CInitializerList a -> a -> CInitializer a
CInitList CInitializerList NodeInfo
initializer (CExpr -> NodeInfo
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
node))
            Trav Env ()
act
        CCall CExpr
fun [CExpr]
args NodeInfo
_ -> do
            [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
                FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_ -> do
                    [Type]
argTys <- (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
                    ((Int, ParamDecl, CExpr, Type) -> Trav Env ())
-> [(Int, ParamDecl, CExpr, Type)] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, ParamDecl, CExpr, Type) -> Trav Env ()
checkParam ([Int]
-> [ParamDecl]
-> [CExpr]
-> [Type]
-> [(Int, ParamDecl, CExpr, Type)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Int
1..] [ParamDecl]
params [CExpr]
args [Type]
argTys)
                PtrType (FunctionType (FunType Type
_ [ParamDecl]
params Bool
_) Attributes
_) TypeQuals
_ Attributes
_ -> do
                    [Type]
argTys <- (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
                    ((Int, ParamDecl, CExpr, Type) -> Trav Env ())
-> [(Int, ParamDecl, CExpr, Type)] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, ParamDecl, CExpr, Type) -> Trav Env ()
checkParam ([Int]
-> [ParamDecl]
-> [CExpr]
-> [Type]
-> [(Int, ParamDecl, CExpr, Type)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Int
1..] [ParamDecl]
params [CExpr]
args [Type]
argTys)
                Type
_ -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Trav Env ()
act

        CAssign 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
            let path :: [PathSegment]
path = case CExpr
l of
                         CVar (Ident String
name Int
_ NodeInfo
_) NodeInfo
_ -> [String -> PathSegment
InVariable String
name]
                         CExpr
_                       -> []
            MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
Strict [PathSegment]
path Type
lTy Type
rTy CExpr
r
            Trav Env ()
act

        CExpr
_ -> Trav Env ()
act

    , doStat :: Stmt -> Trav Env () -> Trav Env ()
doStat = \Stmt
node Trav Env ()
act -> do
        case Stmt
node of
            CReturn (Just CExpr
e) NodeInfo
_ -> do
                TravT Env Identity Env
forall s. Trav s s
getUserState TravT Env Identity Env -> (Env -> Trav Env ()) -> Trav Env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Env
env -> case Env -> Maybe Type
retTy Env
env of
                    Just Type
ty -> do
                        Type
actualTy <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
                        MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
Strict [PathSegment
InReturn] Type
ty Type
actualTy CExpr
e
                    Maybe Type
Nothing -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Stmt
_ -> () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Trav Env ()
act
    }
  where
    checkParam :: (Int, ParamDecl, CExpr, Type) -> Trav Env ()
checkParam (Int
i, ParamDecl (VarDecl (VarName (Ident String
name Int
_ NodeInfo
_) Maybe AsmName
_) DeclAttrs
_ Type
expected) NodeInfo
_, CExpr
arg, Type
actual) =
        MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
Strict [Int -> Maybe String -> PathSegment
InParam Int
i (String -> Maybe String
forall a. a -> Maybe a
Just String
name)] Type
expected Type
actual CExpr
arg
    checkParam (Int
i, ParamDecl (VarDecl VarName
_ DeclAttrs
_ Type
expected) NodeInfo
_, CExpr
arg, Type
actual) =
        MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
Strict [Int -> Maybe String -> PathSegment
InParam Int
i Maybe String
forall a. Maybe a
Nothing] Type
expected Type
actual CExpr
arg
    checkParam (Int, ParamDecl, CExpr, Type)
_ = () -> Trav Env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkInitializer :: MatchMode -> Type -> Initializer -> Trav Env ()
checkInitializer MatchMode
mode Type
ty Initializer
initializer = do
        Maybe GlobalDecls
decls <- Env -> Maybe GlobalDecls
globalDecls (Env -> Maybe GlobalDecls)
-> TravT Env Identity Env -> TravT Env Identity (Maybe GlobalDecls)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TravT Env Identity Env
forall s. Trav s s
getUserState
        case Initializer
initializer of
            CInitExpr CExpr
e NodeInfo
_ -> do
                Type
actual <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e
                MatchMode -> [PathSegment] -> Type -> Type -> CExpr -> Trav Env ()
checkStrictMatch MatchMode
mode [] Type
ty Type
actual CExpr
e
            CInitList CInitializerList NodeInfo
list NodeInfo
_ -> do
                let mTypes :: [Type]
mTypes = [Type] -> (GlobalDecls -> [Type]) -> Maybe GlobalDecls -> [Type]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Type -> GlobalDecls -> [Type]
memberTypes Type
ty) Maybe GlobalDecls
decls
                ((Type, ([CPartDesignator NodeInfo], Initializer)) -> Trav Env ())
-> [(Type, ([CPartDesignator NodeInfo], Initializer))]
-> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Type -> ([CPartDesignator NodeInfo], Initializer) -> Trav Env ())
-> (Type, ([CPartDesignator NodeInfo], Initializer)) -> Trav Env ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (MatchMode
-> Type -> ([CPartDesignator NodeInfo], Initializer) -> Trav Env ()
checkInitializerList MatchMode
mode)) ([Type]
-> CInitializerList NodeInfo
-> [(Type, ([CPartDesignator NodeInfo], Initializer))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
mTypes CInitializerList NodeInfo
list)

    checkInitializerList :: MatchMode
-> Type -> ([CPartDesignator NodeInfo], Initializer) -> Trav Env ()
checkInitializerList MatchMode
mode Type
ty = \case
        ([CPartDesignator NodeInfo]
_, Initializer
initializer) -> MatchMode -> Type -> Initializer -> Trav Env ()
checkInitializer MatchMode
mode Type
ty Initializer
initializer


memberTypes :: Type -> GlobalDecls -> [Type]
memberTypes :: Type -> GlobalDecls -> [Type]
memberTypes (Type -> Type
canonicalType -> DirectType (TyComp (CompTypeRef SUERef
ref CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_) (GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
tags Map Ident TypeDef
_) =
    case SUERef -> Map SUERef TagDef -> Maybe TagDef
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SUERef
ref Map SUERef TagDef
tags of
        Just (CompDef (CompType SUERef
_ CompTyKind
_ [MemberDecl]
members Attributes
_ NodeInfo
_)) -> (MemberDecl -> Maybe Type) -> [MemberDecl] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MemberDecl -> Maybe Type
getMemberType [MemberDecl]
members
        Maybe TagDef
_ -> []
  where
    getMemberType :: MemberDecl -> Maybe Type
getMemberType (MemberDecl (VarDecl VarName
_ DeclAttrs
_ Type
t) Maybe CExpr
_ NodeInfo
_) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
    getMemberType MemberDecl
_                                = Maybe Type
forall a. Maybe a
Nothing
memberTypes (Type -> Type
canonicalType -> ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
_) GlobalDecls
_ = Type -> [Type]
forall a. a -> [a]
repeat Type
t
memberTypes Type
t GlobalDecls
_                                    = [Type
t]


getMainTypedefs :: GlobalDecls -> Map SUERef Ident
getMainTypedefs :: GlobalDecls -> Map SUERef Ident
getMainTypedefs (GlobalDecls Map Ident IdentDecl
_ Map SUERef TagDef
_ Map Ident TypeDef
gTypedefs) =
    (SUERef -> [Ident] -> Maybe Ident)
-> Map SUERef [Ident] -> Map SUERef Ident
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey SUERef -> [Ident] -> Maybe Ident
selectMain Map SUERef [Ident]
grouped
  where
    allTypedefs :: [(SUERef, Ident)]
allTypedefs = [ (SUERef
ref, Ident
i) | (Ident
i, TypeDef Ident
_ Type
ty Attributes
_ NodeInfo
_) <- Map Ident TypeDef -> [(Ident, TypeDef)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Ident TypeDef
gTypedefs
                             , Just SUERef
ref <- [Type -> Maybe SUERef
getSUERef Type
ty] ]

    grouped :: Map SUERef [Ident]
grouped = ([Ident] -> [Ident] -> [Ident])
-> [(SUERef, [Ident])] -> Map SUERef [Ident]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
(++) [ (SUERef
ref, [Ident
i]) | (SUERef
ref, Ident
i) <- [(SUERef, Ident)]
allTypedefs ]

    selectMain :: SUERef -> [Ident] -> Maybe Ident
selectMain SUERef
_ [Ident
ident] = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
ident
    selectMain SUERef
ref [Ident]
idents = case SUERef
ref of
        NamedRef Ident
name -> (Ident -> Bool) -> [Ident] -> Maybe Ident
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Ident
i -> Ident -> String
idName Ident
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> String
idName Ident
name) [Ident]
idents
        SUERef
_             -> Maybe Ident
forall a. Maybe a
Nothing

    getSUERef :: Type -> Maybe SUERef
getSUERef = \case
        DirectType (TyComp (CompTypeRef SUERef
ref CompTyKind
_ NodeInfo
_)) TypeQuals
_ Attributes
_ -> SUERef -> Maybe SUERef
forall a. a -> Maybe a
Just SUERef
ref
        DirectType (TyEnum (EnumTypeRef SUERef
ref NodeInfo
_)) TypeQuals
_ Attributes
_   -> SUERef -> Maybe SUERef
forall a. a -> Maybe a
Just SUERef
ref
        Type
_                                             -> Maybe SUERef
forall a. Maybe a
Nothing


analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> Trav Env ()
analyse GlobalDecls
decls = do
    (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{mainTypedefs :: Map SUERef Ident
mainTypedefs = GlobalDecls -> Map SUERef Ident
getMainTypedefs GlobalDecls
decls, globalDecls :: Maybe GlobalDecls
globalDecls = GlobalDecls -> Maybe GlobalDecls
forall a. a -> Maybe a
Just GlobalDecls
decls}
    AstActions (TravT Env Identity) -> GlobalDecls -> Trav Env ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
traverseAst AstActions (TravT Env Identity)
linter GlobalDecls
decls


descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr = (GlobalDecls -> Trav Env ()
analyse, (Text
"strict-typedef", [Text] -> Text
Text.unlines
    [ Text
"Implements strict typedef checking."
    , Text
""
    , Text
"This linter ensures that logically distinct types (represented by different"
    , Text
"typedefs) are not accidentally mixed, even if they have the same underlying"
    , Text
"representation. This is particularly useful for identifiers, indices, and"
    , Text
"role-based types."
    ]))