{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE TupleSections     #-}
module Tokstyle.Linter.TaggedUnion (descr) where

import           Control.Monad               (forM_, when)
import           Control.Monad.State.Strict  (State, execState, get, modify,
                                              put)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..), foldFixM, unFix)
import           Data.List                   (elemIndex, find, isPrefixOf,
                                              sortBy)
import qualified Data.Map.Strict             as Map
import           Data.Maybe                  (isJust, mapMaybe)
import           Data.Ord                    (comparing)
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Debug.Trace                 (traceM)
import qualified Debug.Trace                 as Debug
import           Language.Cimple             (BinaryOp (..), Lexeme (..),
                                              LiteralType (..), Node,
                                              NodeF (..), lexemeText)
import qualified Language.Cimple             as C
import           Language.Cimple.Diagnostics (HasDiagnostics (..), warn)
import           Language.Cimple.TraverseAst (AstActions (..), astActions,
                                              doNode, traverseAst)
import           Text.Read                   (readMaybe)
import qualified Tokstyle.Common             as Common
import           Tokstyle.Common.TypeSystem  (StdType (..), TypeDescr (..),
                                              TypeInfo (..), TypeRef (..),
                                              TypeSystem, collect, collectTypes,
                                              getTypeRefName, lookupType)


data LinterState = LinterState
    { LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards   :: [(Node (C.Lexeme Text), Text, [Text])]
    , LinterState -> [Text]
warnings :: [Text]
    , LinterState -> Map Text Text
varTypes :: Map.Map Text Text
    }

instance HasDiagnostics LinterState where
    addDiagnostic :: Text -> LinterState -> LinterState
addDiagnostic Text
w LinterState
st =
        String -> LinterState -> LinterState
forall a. String -> a -> a
dtrace (String
"Adding diagnostic: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
w) (LinterState -> LinterState) -> LinterState -> LinterState
forall a b. (a -> b) -> a -> b
$
        LinterState
st { warnings :: [Text]
warnings = Text
w Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: LinterState -> [Text]
warnings LinterState
st }

debugging :: Bool
debugging :: Bool
debugging = Bool
False

dtraceM :: String -> State LinterState ()
dtraceM :: String -> State LinterState ()
dtraceM String
msg = Bool -> State LinterState () -> State LinterState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugging (String -> State LinterState ()
forall (f :: * -> *). Applicative f => String -> f ()
Debug.traceM String
msg)

dtrace :: String -> a -> a
dtrace :: String -> a -> a
dtrace String
msg = if Bool
debugging then String -> a -> a
forall a. String -> a -> a
Debug.trace String
msg else a -> a
forall a. a -> a
id


isVoidPtr :: (Lexeme Text, TypeInfo) -> Bool
isVoidPtr :: (Lexeme Text, TypeInfo) -> Bool
isVoidPtr (Lexeme Text
_, TypeInfo
ty) = TypeInfo -> Bool
isVoid TypeInfo
ty
  where
    isVoid :: TypeInfo -> Bool
isVoid (Pointer (BuiltinType StdType
VoidTy)) = Bool
True
    isVoid (Nullable TypeInfo
t)                   = TypeInfo -> Bool
isVoid TypeInfo
t
    isVoid (Nonnull TypeInfo
t)                    = TypeInfo -> Bool
isVoid TypeInfo
t
    isVoid (Owner TypeInfo
t)                      = TypeInfo -> Bool
isVoid TypeInfo
t
    isVoid (Const TypeInfo
t)                      = TypeInfo -> Bool
isVoid TypeInfo
t
    isVoid TypeInfo
_                              = Bool
False


typeSize :: TypeSystem -> TypeInfo -> Maybe Int
typeSize :: TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts = \case
    BuiltinType StdType
BoolTy  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    BuiltinType StdType
CharTy  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    BuiltinType StdType
U08Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    BuiltinType StdType
S08Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    BuiltinType StdType
U16Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
    BuiltinType StdType
S16Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
    BuiltinType StdType
U32Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
    BuiltinType StdType
S32Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
    BuiltinType StdType
U64Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    BuiltinType StdType
S64Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    BuiltinType StdType
SizeTy  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    BuiltinType StdType
F32Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
    BuiltinType StdType
F64Ty   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    Pointer TypeInfo
_           -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8
    Owner TypeInfo
t             -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t
    Nonnull TypeInfo
t           -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t
    Nullable TypeInfo
t          -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t
    Const TypeInfo
t             -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t
    Sized TypeInfo
t Lexeme Text
_           -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t
    Array (Just TypeInfo
t) [TypeInfo]
dims -> Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
t Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TypeInfo] -> Maybe Int
forall (t :: * -> *) b.
(Num b, Traversable t, Read b) =>
t TypeInfo -> Maybe b
productOfDims [TypeInfo]
dims
    TypeRef TypeRef
_ (L AlexPosn
_ LexemeClass
_ Text
n) -> Text -> Maybe Int
lookupTypeSize Text
n
    TypeInfo
_                   -> Maybe Int
forall a. Maybe a
Nothing
  where
    productOfDims :: t TypeInfo -> Maybe b
productOfDims t TypeInfo
dims = t b -> b
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (t b -> b) -> Maybe (t b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeInfo -> Maybe b) -> t TypeInfo -> Maybe (t b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeInfo -> Maybe b
forall a. Read a => TypeInfo -> Maybe a
getDim t TypeInfo
dims
    getDim :: TypeInfo -> Maybe a
getDim (IntLit (L AlexPosn
_ LexemeClass
_ Text
val)) = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
val)
    getDim TypeInfo
_                    = Maybe a
forall a. Maybe a
Nothing

    lookupTypeSize :: Text -> Maybe Int
lookupTypeSize Text
name = case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
name TypeSystem
ts of
        Just (StructDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
members) -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> Maybe [Int] -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Lexeme Text, TypeInfo) -> Maybe Int)
-> [(Lexeme Text, TypeInfo)] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts (TypeInfo -> Maybe Int)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
members
        Just (UnionDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
members)  -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> Maybe [Int] -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Lexeme Text, TypeInfo) -> Maybe Int)
-> [(Lexeme Text, TypeInfo)] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts (TypeInfo -> Maybe Int)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
members
        Just (EnumDescr Lexeme Text
_ [TypeInfo]
_)         -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
        Just (IntDescr Lexeme Text
_ StdType
_)          -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
        Just (AliasDescr Lexeme Text
_ TypeInfo
target)   -> TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts TypeInfo
target
        Maybe TypeDescr
_                            -> Maybe Int
forall a. Maybe a
Nothing


isCompatible :: TypeSystem -> [(Lexeme Text, TypeInfo)] -> Bool
isCompatible :: TypeSystem -> [(Lexeme Text, TypeInfo)] -> Bool
isCompatible TypeSystem
ts [(Lexeme Text, TypeInfo)]
members =
    case ((Lexeme Text, TypeInfo) -> Maybe Int)
-> [(Lexeme Text, TypeInfo)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TypeSystem -> TypeInfo -> Maybe Int
typeSize TypeSystem
ts (TypeInfo -> Maybe Int)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
members of
        [Int]
sizes | [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
sizes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Lexeme Text, TypeInfo)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Lexeme Text, TypeInfo)]
members Bool -> Bool -> Bool
&& Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
sizes) ->
            (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Int
forall a. [a] -> a
head [Int]
sizes) [Int]
sizes
        [Int]
_ -> Bool
False


isBuiltin :: TypeInfo -> Bool
isBuiltin :: TypeInfo -> Bool
isBuiltin (BuiltinType StdType
_)    = Bool
True
isBuiltin (Const TypeInfo
t)          = TypeInfo -> Bool
isBuiltin TypeInfo
t
isBuiltin (Nonnull TypeInfo
t)        = TypeInfo -> Bool
isBuiltin TypeInfo
t
isBuiltin (Nullable TypeInfo
t)       = TypeInfo -> Bool
isBuiltin TypeInfo
t
isBuiltin (Sized TypeInfo
t Lexeme Text
_)        = TypeInfo -> Bool
isBuiltin TypeInfo
t
isBuiltin (Array (Just TypeInfo
t) [TypeInfo]
_) = TypeInfo -> Bool
isBuiltin TypeInfo
t
isBuiltin (Array Maybe TypeInfo
Nothing [TypeInfo]
_)  = Bool
True -- Array of self? Should not happen in this context.
isBuiltin TypeInfo
_                  = Bool
False


needsTagging :: TypeSystem -> TypeDescr -> Bool
needsTagging :: TypeSystem -> TypeDescr -> Bool
needsTagging TypeSystem
ts desc :: TypeDescr
desc@(UnionDescr (L AlexPosn
_ LexemeClass
_ Text
uname) [(Lexeme Text, TypeInfo)]
members)
    | Text
uname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"IP_Union" = Bool
False
    | ((Lexeme Text, TypeInfo) -> Bool)
-> [(Lexeme Text, TypeInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TypeInfo -> Bool
isBuiltin (TypeInfo -> Bool)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
members Bool -> Bool -> Bool
&& TypeSystem -> [(Lexeme Text, TypeInfo)] -> Bool
isCompatible TypeSystem
ts [(Lexeme Text, TypeInfo)]
members = Bool
False
    | Bool
otherwise = Bool
True
needsTagging TypeSystem
_ TypeDescr
_ = Bool
False


isCorrectTag :: Text -> Text -> Text -> Bool
isCorrectTag :: Text -> Text -> Text -> Bool
isCorrectTag Text
prefix Text
mText Text
tagValue =
    let -- Normalize by converting to uppercase and splitting into words
        toWords :: Text -> [Text]
toWords Text
name = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"_" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.toUpper Text
name

        mWords :: [Text]
mWords = Text -> [Text]
toWords Text
mText
        vFullWords :: [Text]
vFullWords = Text -> [Text]
toWords Text
tagValue
        vPrefixWords :: [Text]
vPrefixWords = Text -> [Text]
toWords Text
prefix

        -- Strip prefix words from the beginning of tag words
        vWords :: [Text]
vWords = if [Text]
vPrefixWords [Text] -> [Text] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
vFullWords
                 then Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
vPrefixWords) [Text]
vFullWords
                 else [Text]
vFullWords

        -- Principled matching: m's words must appear as a contiguous sub-sequence in v's words.
        -- E.g. 'friend_message' matches 'TOX_EVENT_FRIEND_MESSAGE'
        -- 'ptr' matches 'TAG_PTR'
        -- 'u32' matches 'UINT32' (we handle this as a single word match)

        isSubSeq :: [Text] -> [Text] -> Bool
isSubSeq [] [Text]
_ = Bool
True
        isSubSeq [Text]
_ [] = Bool
False
        isSubSeq sub :: [Text]
sub@(Text
s:[Text]
ss) (Text
x:[Text]
xs)
            | Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x Bool -> Bool -> Bool
|| Text -> Text -> Bool
matchAbbrev Text
s Text
x = [Text]
ss [Text] -> [Text] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
xs Bool -> Bool -> Bool
|| [Text] -> [Text] -> Bool
isSubSeq [Text]
sub [Text]
xs
            | Bool
otherwise = [Text] -> [Text] -> Bool
isSubSeq [Text]
sub [Text]
xs

        matchAbbrev :: Text -> Text -> Bool
matchAbbrev Text
m Text
v =
            let normalize :: Text -> Text
normalize Text
n = (Char -> Bool) -> Text -> Text
Text.filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"AEIOU" :: String)) Text
n
            in Text -> Text
normalize Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
normalize Text
v
               Bool -> Bool -> Bool
|| Text
m Text -> Text -> Bool
`Text.isPrefixOf` Text
v
               Bool -> Bool -> Bool
|| Text
v Text -> Text -> Bool
`Text.isPrefixOf` Text
m
               Bool -> Bool -> Bool
|| Text
m Text -> Text -> Bool
`Text.isSuffixOf` Text
v
               Bool -> Bool -> Bool
|| Text
v Text -> Text -> Bool
`Text.isSuffixOf` Text
m

    in [Text] -> [Text] -> Bool
isSubSeq [Text]
mWords [Text]
vWords


-- | Finds all (StructName, UnionMemberName, TagMemberName, UnionTypeName, EnumTypeName, Prefix, [Errors])
findTaggedUnions :: TypeSystem -> [(Text, Text, Text, Text, Text, Text, [Text])]
findTaggedUnions :: TypeSystem -> [(Text, Text, Text, Text, Text, Text, [Text])]
findTaggedUnions TypeSystem
ts = (TypeDescr -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [TypeDescr] -> [(Text, Text, Text, Text, Text, Text, [Text])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypeDescr -> [(Text, Text, Text, Text, Text, Text, [Text])]
findInStruct (TypeSystem -> [TypeDescr]
forall k a. Map k a -> [a]
Map.elems TypeSystem
ts)
  where
    findInStruct :: TypeDescr -> [(Text, Text, Text, Text, Text, Text, [Text])]
findInStruct (StructDescr (L AlexPosn
_ LexemeClass
_ Text
sname) [(Lexeme Text, TypeInfo)]
members) =
        String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace (String
"Checking struct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
sname) ([(Text, Text, Text, Text, Text, Text, [Text])]
 -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a b. (a -> b) -> a -> b
$
        let unions :: [(Lexeme Text, TypeInfo)]
unions = ((Lexeme Text, TypeInfo) -> Bool)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeInfo -> Bool
isInterestingUnion (TypeInfo -> Bool)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
members
        in String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace (String
"Found unions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show (((Lexeme Text, TypeInfo) -> Text)
-> [(Lexeme Text, TypeInfo)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText (Lexeme Text -> Text)
-> ((Lexeme Text, TypeInfo) -> Lexeme Text)
-> (Lexeme Text, TypeInfo)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> Lexeme Text
forall a b. (a, b) -> a
fst) [(Lexeme Text, TypeInfo)]
unions)) ([(Text, Text, Text, Text, Text, Text, [Text])]
 -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a b. (a -> b) -> a -> b
$
           ((Lexeme Text, TypeInfo)
 -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [(Lexeme Text, TypeInfo)]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text
-> [(Lexeme Text, TypeInfo)]
-> (Lexeme Text, TypeInfo)
-> [(Text, Text, Text, Text, Text, Text, [Text])]
findTag Text
sname [(Lexeme Text, TypeInfo)]
members) [(Lexeme Text, TypeInfo)]
unions
    findInStruct TypeDescr
_ = []

    isInterestingUnion :: TypeInfo -> Bool
isInterestingUnion (TypeRef TypeRef
UnionRef (L AlexPosn
_ LexemeClass
_ Text
uname)) =
        case Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
Text.toLower Text
uname) TypeSystem
ts of
            Just TypeDescr
desc -> TypeSystem -> TypeDescr -> Bool
needsTagging TypeSystem
ts TypeDescr
desc
            Maybe TypeDescr
Nothing   -> Bool
False
    isInterestingUnion TypeInfo
_ = Bool
False

    findTag :: Text
-> [(Lexeme Text, TypeInfo)]
-> (Lexeme Text, TypeInfo)
-> [(Text, Text, Text, Text, Text, Text, [Text])]
findTag Text
sname [(Lexeme Text, TypeInfo)]
members (L AlexPosn
_ LexemeClass
_ Text
mname, TypeRef TypeRef
UnionRef (L AlexPosn
_ LexemeClass
_ Text
uname)) =
        let ([(Lexeme Text, TypeInfo)]
before, [(Lexeme Text, TypeInfo)]
_) = ((Lexeme Text, TypeInfo) -> Bool)
-> [(Lexeme Text, TypeInfo)]
-> ([(Lexeme Text, TypeInfo)], [(Lexeme Text, TypeInfo)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
mname) (Text -> Bool)
-> ((Lexeme Text, TypeInfo) -> Text)
-> (Lexeme Text, TypeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText (Lexeme Text -> Text)
-> ((Lexeme Text, TypeInfo) -> Lexeme Text)
-> (Lexeme Text, TypeInfo)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> Lexeme Text
forall a b. (a, b) -> a
fst) [(Lexeme Text, TypeInfo)]
members
            tags :: [(Lexeme Text, TypeInfo)]
tags = ((Lexeme Text, TypeInfo) -> Bool)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeInfo -> Bool
isPotentialTag (TypeInfo -> Bool)
-> ((Lexeme Text, TypeInfo) -> TypeInfo)
-> (Lexeme Text, TypeInfo)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> TypeInfo
forall a b. (a, b) -> b
snd) [(Lexeme Text, TypeInfo)]
before
        in String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace (String
"findTag: sname=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
sname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" mname=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
mname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" uname=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
uname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tags=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show (((Lexeme Text, TypeInfo) -> Text)
-> [(Lexeme Text, TypeInfo)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText (Lexeme Text -> Text)
-> ((Lexeme Text, TypeInfo) -> Lexeme Text)
-> (Lexeme Text, TypeInfo)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, TypeInfo) -> Lexeme Text
forall a b. (a, b) -> a
fst) [(Lexeme Text, TypeInfo)]
tags)) ([(Text, Text, Text, Text, Text, Text, [Text])]
 -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a b. (a -> b) -> a -> b
$
           case [(Lexeme Text, TypeInfo)]
tags of
            ((L AlexPosn
_ LexemeClass
_ Text
tname, TypeInfo
tagTy) : [(Lexeme Text, TypeInfo)]
_) ->
                String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace (String
"  found potential tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
tname) ([(Text, Text, Text, Text, Text, Text, [Text])]
 -> [(Text, Text, Text, Text, Text, Text, [Text])])
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a b. (a -> b) -> a -> b
$
                case TypeInfo -> Maybe Text
getEnumName TypeInfo
tagTy of
                    Just Text
ename ->
                        case Text -> Text -> Maybe (Text, [Text])
checkOrder Text
ename Text
uname of
                            Just (Text
prefix, [Text]
errs) -> [(Text
sname, Text
mname, Text
tname, Text
uname, Text
ename, Text
prefix, [Text]
errs)]
                            Maybe (Text, [Text])
Nothing             -> String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace String
"  checkOrder failed" []
                    Maybe Text
Nothing -> String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace String
"  not an enum type" []
            [(Lexeme Text, TypeInfo)]
_ -> String
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. String -> a -> a
dtrace String
"  no potential tags found before union" []
    findTag Text
_ [(Lexeme Text, TypeInfo)]
_ (Lexeme Text, TypeInfo)
_ = []

    getEnumName :: TypeInfo -> Maybe Text
getEnumName (TypeRef TypeRef
EnumRef (L AlexPosn
_ LexemeClass
_ Text
n)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n
    getEnumName TypeInfo
_                           = Maybe Text
forall a. Maybe a
Nothing

    isPotentialTag :: TypeInfo -> Bool
isPotentialTag (TypeRef TypeRef
EnumRef Lexeme Text
_) = Bool
True
    isPotentialTag TypeInfo
_                   = Bool
False

    longestCommonPrefix :: [Text] -> Text
longestCommonPrefix [] = Text
""
    longestCommonPrefix (Text
x:[Text]
xs) = (Text -> Text -> Text) -> Text -> [Text] -> Text
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Text -> Text -> Text
commonPrefix Text
x [Text]
xs
      where
        commonPrefix :: Text -> Text -> Text
commonPrefix Text
a Text
b = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ((Char, Char) -> Char) -> [(Char, Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
forall a b. (a, b) -> a
fst ([(Char, Char)] -> String) -> [(Char, Char)] -> String
forall a b. (a -> b) -> a -> b
$ ((Char, Char) -> Bool) -> [(Char, Char)] -> [(Char, Char)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> Char -> Bool) -> (Char, Char) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==)) ([(Char, Char)] -> [(Char, Char)])
-> [(Char, Char)] -> [(Char, Char)]
forall a b. (a -> b) -> a -> b
$ String -> String -> [(Char, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Text -> String
Text.unpack Text
a) (Text -> String
Text.unpack Text
b)

    checkOrder :: Text -> Text -> Maybe (Text, [Text])
checkOrder Text
ename Text
uname =
        case (Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
Text.toLower Text
ename) TypeSystem
ts, Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
Text.toLower Text
uname) TypeSystem
ts) of
            (Just (EnumDescr Lexeme Text
_ [TypeInfo]
enumMembers), Just (UnionDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
unionMembers)) ->
                let enumLexemes :: [Text]
enumLexemes = (TypeInfo -> Maybe Text) -> [TypeInfo] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeInfo -> Maybe Text
getEnumLexeme [TypeInfo]
enumMembers
                    getEnumLexeme :: TypeInfo -> Maybe Text
getEnumLexeme (EnumMem Lexeme Text
l) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
l
                    getEnumLexeme TypeInfo
_           = Maybe Text
forall a. Maybe a
Nothing

                    prefix :: Text
prefix = [Text] -> Text
longestCommonPrefix [Text]
enumLexemes

                    findMatch :: Text -> Maybe Text
findMatch Text
n = (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Text -> Text -> Bool
isCorrectTag Text
prefix Text
n) [Text]
enumLexemes

                    unionMatches :: [(Lexeme Text, Maybe Text)]
unionMatches = ((Lexeme Text, TypeInfo) -> (Lexeme Text, Maybe Text))
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
n), TypeInfo
_) -> (Lexeme Text
l, Text -> Maybe Text
findMatch Text
n)) [(Lexeme Text, TypeInfo)]
unionMembers
                    matched :: [(Lexeme Text, Maybe Text)]
matched = ((Lexeme Text, Maybe Text) -> Bool)
-> [(Lexeme Text, Maybe Text)] -> [(Lexeme Text, Maybe Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool)
-> ((Lexeme Text, Maybe Text) -> Maybe Text)
-> (Lexeme Text, Maybe Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme Text, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd) [(Lexeme Text, Maybe Text)]
unionMatches

                    -- Heuristic: if at least some members match, it's likely the tag.
                    isLikelyTag :: Bool
isLikelyTag = Bool -> Bool
not ([(Lexeme Text, Maybe Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Lexeme Text, Maybe Text)]
matched)
                in if Bool -> Bool
not Bool
isLikelyTag
                   then Maybe (Text, [Text])
forall a. Maybe a
Nothing
                   else
                       let missingMatches :: [Text]
missingMatches = [ Text
n | (L AlexPosn
_ LexemeClass
_ Text
n, Maybe Text
Nothing) <- [(Lexeme Text, Maybe Text)]
unionMatches ]
                           errs0 :: [Text]
errs0 = [ Text
"union member `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` does not have a matching enum member in `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" | Text
n <- [Text]
missingMatches ]

                           voidPtrs :: [Text]
voidPtrs = [ Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
n | m :: (Lexeme Text, TypeInfo)
m@(Lexeme Text
n, TypeInfo
_) <- [(Lexeme Text, TypeInfo)]
unionMembers, (Lexeme Text, TypeInfo) -> Bool
isVoidPtr (Lexeme Text, TypeInfo)
m ]
                           errs1 :: [Text]
errs1 = [ Text
"union `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` contains a void pointer: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" | Text
v <- [Text]
voidPtrs ]

                           matchedIndices :: [(Lexeme Text, Int)]
matchedIndices = ((Lexeme Text, Maybe Text) -> Maybe (Lexeme Text, Int))
-> [(Lexeme Text, Maybe Text)] -> [(Lexeme Text, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Lexeme Text
l, Maybe Text
m) -> (Lexeme Text
l,) (Int -> (Lexeme Text, Int))
-> Maybe Int -> Maybe (Lexeme Text, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Text
m Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Text]
enumLexemes))) [(Lexeme Text, Maybe Text)]
unionMatches

                           isSorted :: [(a, a)] -> Bool
isSorted [] = Bool
True
                           isSorted [(a, a)
_] = Bool
True
                           isSorted ((a
_, a
i1):rest :: [(a, a)]
rest@((a
_, a
i2):[(a, a)]
_)) = a
i1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
i2 Bool -> Bool -> Bool
&& [(a, a)] -> Bool
isSorted [(a, a)]
rest

                           errs2 :: [Text]
errs2 = if [(Lexeme Text, Int)] -> Bool
forall a a. Ord a => [(a, a)] -> Bool
isSorted [(Lexeme Text, Int)]
matchedIndices
                                   then []
                                   else let expected :: [Lexeme Text]
expected = ((Lexeme Text, Int) -> Lexeme Text)
-> [(Lexeme Text, Int)] -> [Lexeme Text]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text, Int) -> Lexeme Text
forall a b. (a, b) -> a
fst ([(Lexeme Text, Int)] -> [Lexeme Text])
-> [(Lexeme Text, Int)] -> [Lexeme Text]
forall a b. (a -> b) -> a -> b
$ ((Lexeme Text, Int) -> (Lexeme Text, Int) -> Ordering)
-> [(Lexeme Text, Int)] -> [(Lexeme Text, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Lexeme Text, Int) -> Int)
-> (Lexeme Text, Int) -> (Lexeme Text, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Lexeme Text, Int) -> Int
forall a b. (a, b) -> b
snd) [(Lexeme Text, Int)]
matchedIndices
                                        in [ Text
"order of members in union `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should be changed to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " ((Lexeme Text -> Text) -> [Lexeme Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText [Lexeme Text]
expected) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` to match enum `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" ]
                       in (Text, [Text]) -> Maybe (Text, [Text])
forall a. a -> Maybe a
Just (Text
prefix, [Text]
errs0 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
errs1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
errs2)
            (Maybe TypeDescr, Maybe TypeDescr)
_ -> Maybe (Text, [Text])
forall a. Maybe a
Nothing


-- | Finds unions with pointers that are NOT used in a tagged way in any struct.
findUntaggedUnions :: TypeSystem -> [(Text, Lexeme Text)]
findUntaggedUnions :: TypeSystem -> [(Text, Lexeme Text)]
findUntaggedUnions TypeSystem
ts = (TypeDescr -> Maybe (Text, Lexeme Text))
-> [TypeDescr] -> [(Text, Lexeme Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TypeDescr -> Maybe (Text, Lexeme Text)
check (TypeSystem -> [TypeDescr]
forall k a. Map k a -> [a]
Map.elems TypeSystem
ts)
  where
    check :: TypeDescr -> Maybe (Text, Lexeme Text)
check desc :: TypeDescr
desc@(UnionDescr name :: Lexeme Text
name@(L AlexPosn
_ LexemeClass
_ Text
uname) [(Lexeme Text, TypeInfo)]
_)
        | TypeSystem -> TypeDescr -> Bool
needsTagging TypeSystem
ts TypeDescr
desc Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
isUsedAsTagged Text
uname) = (Text, Lexeme Text) -> Maybe (Text, Lexeme Text)
forall a. a -> Maybe a
Just (Text
uname, Lexeme Text
name)
    check TypeDescr
_ = Maybe (Text, Lexeme Text)
forall a. Maybe a
Nothing

    isUsedAsTagged :: Text -> Bool
isUsedAsTagged Text
uname = Text
uname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Text, Text, Text, Text, Text, Text, [Text]) -> Text)
-> [(Text, Text, Text, Text, Text, Text, [Text])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
_, Text
_, Text
_, Text
u, Text
_, Text
_, [Text]
_) -> Text
u) (TypeSystem -> [(Text, Text, Text, Text, Text, Text, [Text])]
findTaggedUnions TypeSystem
ts)



linter :: TypeSystem -> [(Text, Text, Text, Text, Text, Text, [Text])] -> [Text] -> AstActions (State LinterState) Text
linter :: TypeSystem
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [Text]
-> AstActions (State LinterState) Text
linter TypeSystem
ts [(Text, Text, Text, Text, Text, Text, [Text])]
tagged [Text]
untagged = AstActions (State LinterState) Text
actions
  where
    withBoolCtx :: State LinterState a -> State LinterState a
    withBoolCtx :: State LinterState a -> State LinterState a
withBoolCtx State LinterState a
act = State LinterState a
act

    getTypeRefNameFromNode :: Node (Lexeme Text) -> Maybe Text
getTypeRefNameFromNode Node (Lexeme Text)
n =
        let tys :: [TypeInfo]
tys = State TypeSystem [TypeInfo] -> TypeSystem -> [TypeInfo]
forall s a. State s a -> s -> a
State.evalState ((NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo])
-> Node (Lexeme Text) -> State TypeSystem [TypeInfo]
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo]
collectTypes Node (Lexeme Text)
n) TypeSystem
ts
        in case [TypeInfo]
tys of
            (TypeInfo
t:[TypeInfo]
_) -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
            [TypeInfo]
_     -> Maybe Text
forall a. Maybe a
Nothing

    getVarDecl :: Node (Lexeme Text) -> Maybe (Text, Text)
getVarDecl (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_)) = (Text
name,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe Text
getTypeRefNameFromNode Node (Lexeme Text)
ty
    getVarDecl Node (Lexeme Text)
_                                   = Maybe (Text, Text)
forall a. Maybe a
Nothing

    getTypeOf :: Map Text Text -> Node (Lexeme Text) -> Maybe Text
getTypeOf Map Text Text
vt (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
        C.VarExpr (L AlexPosn
_ LexemeClass
_ Text
v) -> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
v Map Text Text
vt
        C.MemberAccess Node (Lexeme Text)
e Lexeme Text
m -> do
            Text
tName <- Map Text Text -> Node (Lexeme Text) -> Maybe Text
getTypeOf Map Text Text
vt Node (Lexeme Text)
e
            Text -> Text -> Maybe Text
lookupMemberType Text
tName (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
m)
        C.PointerAccess Node (Lexeme Text)
e Lexeme Text
m -> do
            Text
tName <- Map Text Text -> Node (Lexeme Text) -> Maybe Text
getTypeOf Map Text Text
vt Node (Lexeme Text)
e
            Text -> Text -> Maybe Text
lookupMemberType Text
tName (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
m)
        C.ParenExpr Node (Lexeme Text)
e -> Map Text Text -> Node (Lexeme Text) -> Maybe Text
getTypeOf Map Text Text
vt Node (Lexeme Text)
e
        C.CastExpr Node (Lexeme Text)
ty Node (Lexeme Text)
_ -> Node (Lexeme Text) -> Maybe Text
getTypeRefNameFromNode Node (Lexeme Text)
ty
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe Text
forall a. Maybe a
Nothing

    lookupMemberType :: Text -> Text -> Maybe Text
lookupMemberType Text
tName Text
mName =
        case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
tName TypeSystem
ts of
            Just (StructDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
members) -> Text -> [(Lexeme Text, TypeInfo)] -> Maybe Text
forall a. Eq a => a -> [(Lexeme a, TypeInfo)] -> Maybe Text
findMember Text
mName [(Lexeme Text, TypeInfo)]
members
            Just (UnionDescr Lexeme Text
_ [(Lexeme Text, TypeInfo)]
members)  -> Text -> [(Lexeme Text, TypeInfo)] -> Maybe Text
forall a. Eq a => a -> [(Lexeme a, TypeInfo)] -> Maybe Text
findMember Text
mName [(Lexeme Text, TypeInfo)]
members
            Maybe TypeDescr
_                            -> Maybe Text
forall a. Maybe a
Nothing

    findMember :: a -> [(Lexeme a, TypeInfo)] -> Maybe Text
findMember a
mName [(Lexeme a, TypeInfo)]
members =
        case ((Lexeme a, TypeInfo) -> Bool)
-> [(Lexeme a, TypeInfo)] -> [(Lexeme a, TypeInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
mName) (a -> Bool)
-> ((Lexeme a, TypeInfo) -> a) -> (Lexeme a, TypeInfo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme a -> a
forall text. Lexeme text -> text
lexemeText (Lexeme a -> a)
-> ((Lexeme a, TypeInfo) -> Lexeme a) -> (Lexeme a, TypeInfo) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lexeme a, TypeInfo) -> Lexeme a
forall a b. (a, b) -> a
fst) [(Lexeme a, TypeInfo)]
members of
            ((Lexeme a
_, TypeInfo
ty):[(Lexeme a, TypeInfo)]
_) -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
ty
            [(Lexeme a, TypeInfo)]
_           -> Maybe Text
forall a. Maybe a
Nothing

    actions :: AstActions (State LinterState) Text
actions = AstActions (State LinterState) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
file Node (Lexeme Text)
node State LinterState ()
act ->
            case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
                C.Struct (L AlexPosn
_ LexemeClass
_ Text
sname) [Node (Lexeme Text)]
_ -> do
                    let matches :: [(Text, Text, Text, Text, Text, Text, [Text])]
matches = ((Text, Text, Text, Text, Text, Text, [Text]) -> Bool)
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
sn, Text
_, Text
_, Text
_, Text
_, Text
_, [Text]
_) -> Text
sn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
sname) [(Text, Text, Text, Text, Text, Text, [Text])]
tagged
                    [(Text, Text, Text, Text, Text, Text, [Text])]
-> ((Text, Text, Text, Text, Text, Text, [Text])
    -> State LinterState ())
-> State LinterState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Text, Text, Text, Text, Text, [Text])]
matches (((Text, Text, Text, Text, Text, Text, [Text])
  -> State LinterState ())
 -> State LinterState ())
-> ((Text, Text, Text, Text, Text, Text, [Text])
    -> State LinterState ())
-> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \(Text
_, Text
_, Text
_, Text
_, Text
_, Text
_, [Text]
errs) ->
                        [Text] -> (Text -> State LinterState ()) -> State LinterState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
errs ((Text -> State LinterState ()) -> State LinterState ())
-> (Text -> State LinterState ()) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \Text
err -> String -> Node (Lexeme Text) -> Text -> State LinterState ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Node (Lexeme Text)
node Text
err
                    State LinterState ()
act

                C.Union (L AlexPosn
_ LexemeClass
_ Text
uname) [Node (Lexeme Text)]
_ | Text
uname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
untagged -> do
                    String -> Node (Lexeme Text) -> Text -> State LinterState ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Node (Lexeme Text)
node (Text -> State LinterState ()) -> Text -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ Text
"union `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` must be tagged in a struct"
                    State LinterState ()
act

                C.IfStmt Node (Lexeme Text)
cond Node (Lexeme Text)
trueBody Maybe (Node (Lexeme Text))
maybeFalseBody -> do
                    [(Node (Lexeme Text), Text, [Text])]
newGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *).
Monad m =>
Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
cond
                    [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
cond
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
trueBody

                    if Node (Lexeme Text) -> Bool
forall lexeme. Fix (NodeF lexeme) -> Bool
alwaysExits Node (Lexeme Text)
trueBody
                    then do
                        [(Node (Lexeme Text), Text, [Text])]
negGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a.
Monad m =>
Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' Node (Lexeme Text)
cond
                        (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
negGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    else do
                        (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }

                    case Maybe (Node (Lexeme Text))
maybeFalseBody of
                        Just Node (Lexeme Text)
falseBody -> do
                            [(Node (Lexeme Text), Text, [Text])]
negGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a.
Monad m =>
Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' Node (Lexeme Text)
cond
                            (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
negGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                            State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
falseBody
                            if Node (Lexeme Text) -> Bool
forall lexeme. Fix (NodeF lexeme) -> Bool
alwaysExits Node (Lexeme Text)
falseBody
                            then do
                                -- If false branch exits, then true branch's guards must hold for the rest of the function.
                                -- This is already handled by adding newGuards before, but we need to keep them.
                                (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                            else do
                                (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                        Maybe (Node (Lexeme Text))
Nothing -> () -> State LinterState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

                C.WhileStmt Node (Lexeme Text)
cond Node (Lexeme Text)
body -> do
                    [(Node (Lexeme Text), Text, [Text])]
newGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *).
Monad m =>
Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
cond
                    [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
cond
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
body
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }

                C.DoWhileStmt Node (Lexeme Text)
body Node (Lexeme Text)
cond -> do
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
body
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
cond

                C.ForStmt Node (Lexeme Text)
init_ Node (Lexeme Text)
cond Node (Lexeme Text)
incr Node (Lexeme Text)
body -> do
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
init_
                    [(Node (Lexeme Text), Text, [Text])]
newGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *).
Monad m =>
Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
cond
                    [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
cond
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
incr
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
body
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }

                C.SwitchStmt Node (Lexeme Text)
expr [Node (Lexeme Text)]
body -> do
                    -- For a switch, we track the expression being switched on.
                    -- Individual 'case' labels will add the specific tag value.
                    let actions' :: AstActions (State LinterState) Text
actions' = Node (Lexeme Text) -> AstActions (State LinterState) Text
actionsForSwitch Node (Lexeme Text)
expr
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> [Node (Lexeme Text)] -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions' { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions' String
file } [Node (Lexeme Text)]
body

                C.TernaryExpr Node (Lexeme Text)
cond Node (Lexeme Text)
trueExpr Node (Lexeme Text)
falseExpr -> do
                    [(Node (Lexeme Text), Text, [Text])]
newGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *).
Monad m =>
Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
cond
                    [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
cond
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
trueExpr
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
falseExpr
                    (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }

                C.BinaryExpr Node (Lexeme Text)
lhs BinaryOp
op Node (Lexeme Text)
rhs -> do
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ do
                        case BinaryOp
op of
                            BinaryOp
C.BopAnd -> do
                                AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
lhs
                                [(Node (Lexeme Text), Text, [Text])]
newGuards <- Node (Lexeme Text)
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *).
Monad m =>
Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
lhs
                                [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                                (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                                AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
rhs
                                (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                            BinaryOp
_ -> do
                                AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
lhs
                                AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
rhs

                C.UnaryExpr UnaryOp
C.UopNot Node (Lexeme Text)
e -> State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
e

                C.MemberAccess Node (Lexeme Text)
expr Lexeme Text
mname -> do
                    String -> Node (Lexeme Text) -> Lexeme Text -> State LinterState ()
checkAccess String
file Node (Lexeme Text)
expr Lexeme Text
mname
                    State LinterState ()
act

                C.PointerAccess Node (Lexeme Text)
expr Lexeme Text
mname -> do
                    String -> Node (Lexeme Text) -> Lexeme Text -> State LinterState ()
checkAccess String
file Node (Lexeme Text)
expr Lexeme Text
mname
                    State LinterState ()
act

                C.FunctionDefn Scope
_ Node (Lexeme Text)
proto Node (Lexeme Text)
body -> do
                    case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
proto of
                        C.FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
_ [Node (Lexeme Text)]
params -> do
                            let newVars :: Map Text Text
newVars = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ (Node (Lexeme Text) -> Maybe (Text, Text))
-> [Node (Lexeme Text)] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text) -> Maybe (Text, Text)
getVarDecl [Node (Lexeme Text)]
params
                            LinterState
st <- StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                            let oldVars :: Map Text Text
oldVars = LinterState -> Map Text Text
varTypes LinterState
st
                            LinterState -> State LinterState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put LinterState
st { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [], varTypes :: Map Text Text
varTypes = Map Text Text
newVars Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Text Text
oldVars }
                            AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
body
                            (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards LinterState
st, varTypes :: Map Text Text
varTypes = Map Text Text
oldVars }
                        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State LinterState ()
act

                C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_ -> do
                    case Node (Lexeme Text) -> Maybe Text
getTypeRefNameFromNode Node (Lexeme Text)
ty of
                        Just Text
t -> (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { varTypes :: Map Text Text
varTypes = Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Text
t (LinterState -> Map Text Text
varTypes LinterState
s) }
                        Maybe Text
Nothing -> () -> State LinterState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    State LinterState ()
act

                C.AssignExpr Node (Lexeme Text)
lhs AssignOp
C.AopEq Node (Lexeme Text)
rhs -> do
                    case Node (Lexeme Text) -> [(Node (Lexeme Text), Text)]
forall text.
Fix (NodeF (Lexeme text)) -> [(Fix (NodeF (Lexeme text)), text)]
extractGuards' Node (Lexeme Text)
lhs of
                        [(Node (Lexeme Text)
structExpr, Text
tname)] -> do
                            let cExpr :: Node (Lexeme Text)
cExpr = Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
structExpr
                            (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = ((Node (Lexeme Text), Text, [Text]) -> Bool)
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node (Lexeme Text)
gExpr, Text
gTname, [Text]
_) -> Text
gTname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
tname Bool -> Bool -> Bool
|| Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
gExpr Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= Node (Lexeme Text)
cExpr) (LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards LinterState
s) }
                            case Node (Lexeme Text) -> [Text]
forall a. Fix (NodeF (Lexeme a)) -> [a]
extractConstants Node (Lexeme Text)
rhs of
                                [Text
tagValue] -> (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = (Node (Lexeme Text)
structExpr, Text
tname, [Text
tagValue]) (Node (Lexeme Text), Text, [Text])
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. a -> [a] -> [a]
: LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards LinterState
s }
                                [Text]
_          -> () -> State LinterState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        [(Node (Lexeme Text), Text)]
_ -> () -> State LinterState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
lhs
                    State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
rhs

                C.Return{} -> State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx State LinterState ()
act
                C.FunctionCall{} -> State LinterState () -> State LinterState ()
forall a. State LinterState a -> State LinterState a
withBoolCtx State LinterState ()
act

                NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State LinterState ()
act
        }

    actionsForSwitch :: Node (Lexeme Text) -> AstActions (State LinterState) Text
actionsForSwitch Node (Lexeme Text)
switchedExpr = AstActions (State LinterState) Text
actions
        { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
file Node (Lexeme Text)
node State LinterState ()
act ->
            case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
                C.Case Node (Lexeme Text)
val Node (Lexeme Text)
body -> do
                    case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
val of
                        C.LiteralExpr LiteralType
ConstId Lexeme Text
tagValue -> do
                            let newGuards :: [(Node (Lexeme Text), Text, [Text])]
newGuards = [ (Node (Lexeme Text)
expr, Text
tname, [Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
tagValue]) | (Node (Lexeme Text)
expr, Text
tname) <- Node (Lexeme Text) -> [(Node (Lexeme Text), Text)]
forall text.
Fix (NodeF (Lexeme text)) -> [(Fix (NodeF (Lexeme text)), text)]
extractGuards' Node (Lexeme Text)
switchedExpr ]
                            [(Node (Lexeme Text), Text, [Text])]
oldGuards <- LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards (LinterState -> [(Node (Lexeme Text), Text, [Text])])
-> StateT LinterState Identity LinterState
-> StateT LinterState Identity [(Node (Lexeme Text), Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                            (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
newGuards [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                            AstActions (State LinterState) Text
-> Node (Lexeme Text) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State LinterState) Text
actions { doNode :: String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
doNode = \String
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file } Node (Lexeme Text)
body
                            (LinterState -> LinterState) -> State LinterState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState) -> State LinterState ())
-> (LinterState -> LinterState) -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { guards :: [(Node (Lexeme Text), Text, [Text])]
guards = [(Node (Lexeme Text), Text, [Text])]
oldGuards }
                        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State LinterState ()
act
                NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> AstActions (State LinterState) Text
-> String
-> Node (Lexeme Text)
-> State LinterState ()
-> State LinterState ()
forall (f :: * -> *) text.
AstActions f text -> String -> Node (Lexeme text) -> f () -> f ()
doNode AstActions (State LinterState) Text
actions String
file Node (Lexeme Text)
node State LinterState ()
act
        }

    collectGuards' :: Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' (Fix (C.BinaryExpr Node (Lexeme Text)
lhs BinaryOp
BopEq Node (Lexeme Text)
rhs)) = do
        let l :: [(Node (Lexeme Text), Text, [Text])]
l = Node (Lexeme Text)
-> Node (Lexeme Text) -> [(Node (Lexeme Text), Text, [Text])]
forall b a.
Fix (NodeF (Lexeme b))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme b)), b, [a])]
extractGuardsFromBin Node (Lexeme Text)
lhs Node (Lexeme Text)
rhs
        let r :: [(Node (Lexeme Text), Text, [Text])]
r = Node (Lexeme Text)
-> Node (Lexeme Text) -> [(Node (Lexeme Text), Text, [Text])]
forall b a.
Fix (NodeF (Lexeme b))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme b)), b, [a])]
extractGuardsFromBin Node (Lexeme Text)
rhs Node (Lexeme Text)
lhs
        [(Node (Lexeme Text), Text, [Text])]
l_nested <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
lhs
        [(Node (Lexeme Text), Text, [Text])]
r_nested <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
rhs
        [(Node (Lexeme Text), Text, [Text])]
-> m [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Node (Lexeme Text), Text, [Text])]
l [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
r [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
l_nested [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
r_nested)
    collectGuards' (Fix (C.ParenExpr Node (Lexeme Text)
e)) = Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
e
    collectGuards' (Fix (C.BinaryExpr Node (Lexeme Text)
lhs BinaryOp
BopAnd Node (Lexeme Text)
rhs)) = do
        [(Node (Lexeme Text), Text, [Text])]
l <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
lhs
        [(Node (Lexeme Text), Text, [Text])]
r <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
rhs
        [(Node (Lexeme Text), Text, [Text])]
-> m [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Node (Lexeme Text), Text, [Text])]
l [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a. [a] -> [a] -> [a]
++ [(Node (Lexeme Text), Text, [Text])]
r)
    collectGuards' (Fix (C.BinaryExpr Node (Lexeme Text)
lhs BinaryOp
BopOr Node (Lexeme Text)
rhs)) = do
        [(Node (Lexeme Text), Text, [Text])]
l <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
lhs
        [(Node (Lexeme Text), Text, [Text])]
r <- Node (Lexeme Text) -> m [(Node (Lexeme Text), Text, [Text])]
collectGuards' Node (Lexeme Text)
rhs
        let r_facts :: [((Node (Lexeme Text), Text), [Text])]
r_facts = [ ((Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
e, Text
t), [Text]
v) | (Node (Lexeme Text)
e, Text
t, [Text]
v) <- [(Node (Lexeme Text), Text, [Text])]
r ]
        [(Node (Lexeme Text), Text, [Text])]
-> m [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Node (Lexeme Text), Text, [Text])]
 -> m [(Node (Lexeme Text), Text, [Text])])
-> [(Node (Lexeme Text), Text, [Text])]
-> m [(Node (Lexeme Text), Text, [Text])]
forall a b. (a -> b) -> a -> b
$ ((Node (Lexeme Text), Text, [Text])
 -> Maybe (Node (Lexeme Text), Text, [Text]))
-> [(Node (Lexeme Text), Text, [Text])]
-> [(Node (Lexeme Text), Text, [Text])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Node (Lexeme Text)
e, Text
t, [Text]
v) -> (Node (Lexeme Text)
e, Text
t,) ([Text] -> (Node (Lexeme Text), Text, [Text]))
-> ([Text] -> [Text])
-> [Text]
-> (Node (Lexeme Text), Text, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text]
v [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++) ([Text] -> (Node (Lexeme Text), Text, [Text]))
-> Maybe [Text] -> Maybe (Node (Lexeme Text), Text, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node (Lexeme Text), Text)
-> [((Node (Lexeme Text), Text), [Text])] -> Maybe [Text]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
e, Text
t) [((Node (Lexeme Text), Text), [Text])]
r_facts) [(Node (Lexeme Text), Text, [Text])]
l
    collectGuards' Node (Lexeme Text)
_ = [(Node (Lexeme Text), Text, [Text])]
-> m [(Node (Lexeme Text), Text, [Text])]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    collectNegativeGuards' :: Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' (Fix (C.BinaryExpr Fix (NodeF (Lexeme a))
lhs BinaryOp
BopNe Fix (NodeF (Lexeme a))
rhs)) = do
        let l :: [(Fix (NodeF (Lexeme a)), a, [a])]
l = Fix (NodeF (Lexeme a))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme a)), a, [a])]
forall b a.
Fix (NodeF (Lexeme b))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme b)), b, [a])]
extractGuardsFromBin Fix (NodeF (Lexeme a))
lhs Fix (NodeF (Lexeme a))
rhs
        let r :: [(Fix (NodeF (Lexeme a)), a, [a])]
r = Fix (NodeF (Lexeme a))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme a)), a, [a])]
forall b a.
Fix (NodeF (Lexeme b))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme b)), b, [a])]
extractGuardsFromBin Fix (NodeF (Lexeme a))
rhs Fix (NodeF (Lexeme a))
lhs
        [(Fix (NodeF (Lexeme a)), a, [a])]
-> m [(Fix (NodeF (Lexeme a)), a, [a])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Fix (NodeF (Lexeme a)), a, [a])]
l [(Fix (NodeF (Lexeme a)), a, [a])]
-> [(Fix (NodeF (Lexeme a)), a, [a])]
-> [(Fix (NodeF (Lexeme a)), a, [a])]
forall a. [a] -> [a] -> [a]
++ [(Fix (NodeF (Lexeme a)), a, [a])]
r)
    collectNegativeGuards' (Fix (C.ParenExpr Fix (NodeF (Lexeme a))
e)) = Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' Fix (NodeF (Lexeme a))
e
    collectNegativeGuards' (Fix (C.BinaryExpr Fix (NodeF (Lexeme a))
lhs BinaryOp
BopAnd Fix (NodeF (Lexeme a))
rhs)) = do
        -- For AND, we only know that it's NOT true if BOTH are false? No.
        -- If !(A && B), we don't know much.
        [(Fix (NodeF (Lexeme a)), a, [a])]
-> m [(Fix (NodeF (Lexeme a)), a, [a])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    collectNegativeGuards' (Fix (C.BinaryExpr Fix (NodeF (Lexeme a))
lhs BinaryOp
BopOr Fix (NodeF (Lexeme a))
rhs)) = do
        -- For OR, if !(A || B), then !A AND !B.
        [(Fix (NodeF (Lexeme a)), a, [a])]
l <- Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' Fix (NodeF (Lexeme a))
lhs
        [(Fix (NodeF (Lexeme a)), a, [a])]
r <- Fix (NodeF (Lexeme a)) -> m [(Fix (NodeF (Lexeme a)), a, [a])]
collectNegativeGuards' Fix (NodeF (Lexeme a))
rhs
        [(Fix (NodeF (Lexeme a)), a, [a])]
-> m [(Fix (NodeF (Lexeme a)), a, [a])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Fix (NodeF (Lexeme a)), a, [a])]
l [(Fix (NodeF (Lexeme a)), a, [a])]
-> [(Fix (NodeF (Lexeme a)), a, [a])]
-> [(Fix (NodeF (Lexeme a)), a, [a])]
forall a. [a] -> [a] -> [a]
++ [(Fix (NodeF (Lexeme a)), a, [a])]
r)
    collectNegativeGuards' Fix (NodeF (Lexeme a))
_ = [(Fix (NodeF (Lexeme a)), a, [a])]
-> m [(Fix (NodeF (Lexeme a)), a, [a])]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    alwaysExits :: Fix (NodeF lexeme) -> Bool
alwaysExits (Fix (C.Return Maybe (Fix (NodeF lexeme))
_))            = Bool
True
    alwaysExits (Fix (NodeF lexeme (Fix (NodeF lexeme))
C.Break))               = Bool
True
    alwaysExits (Fix (NodeF lexeme (Fix (NodeF lexeme))
C.Continue))            = Bool
True
    alwaysExits (Fix (C.CompoundStmt [Fix (NodeF lexeme)]
stmts))  = (Fix (NodeF lexeme) -> Bool) -> [Fix (NodeF lexeme)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Fix (NodeF lexeme) -> Bool
alwaysExits [Fix (NodeF lexeme)]
stmts
    alwaysExits (Fix (C.IfStmt Fix (NodeF lexeme)
_ Fix (NodeF lexeme)
t (Just Fix (NodeF lexeme)
f))) = Fix (NodeF lexeme) -> Bool
alwaysExits Fix (NodeF lexeme)
t Bool -> Bool -> Bool
&& Fix (NodeF lexeme) -> Bool
alwaysExits Fix (NodeF lexeme)
f
    alwaysExits Fix (NodeF lexeme)
_                             = Bool
False

    extractGuardsFromBin :: Fix (NodeF (Lexeme b))
-> Fix (NodeF (Lexeme a)) -> [(Fix (NodeF (Lexeme b)), b, [a])]
extractGuardsFromBin Fix (NodeF (Lexeme b))
lhs Fix (NodeF (Lexeme a))
rhs =
        [ (Fix (NodeF (Lexeme b))
expr, b
tname, [a
tagValue]) | (Fix (NodeF (Lexeme b))
expr, b
tname) <- Fix (NodeF (Lexeme b)) -> [(Fix (NodeF (Lexeme b)), b)]
forall text.
Fix (NodeF (Lexeme text)) -> [(Fix (NodeF (Lexeme text)), text)]
extractGuards' Fix (NodeF (Lexeme b))
lhs, a
tagValue <- Fix (NodeF (Lexeme a)) -> [a]
forall a. Fix (NodeF (Lexeme a)) -> [a]
extractConstants Fix (NodeF (Lexeme a))
rhs ]

    extractConstants :: Fix (NodeF (Lexeme a)) -> [a]
extractConstants (Fix (C.LiteralExpr LiteralType
ConstId Lexeme a
val)) = [Lexeme a -> a
forall text. Lexeme text -> text
lexemeText Lexeme a
val]
    extractConstants (Fix (C.ParenExpr Fix (NodeF (Lexeme a))
e))             = Fix (NodeF (Lexeme a)) -> [a]
extractConstants Fix (NodeF (Lexeme a))
e
    extractConstants Fix (NodeF (Lexeme a))
_                                 = []

    extractGuards' :: Fix (NodeF (Lexeme text)) -> [(Fix (NodeF (Lexeme text)), text)]
extractGuards' (Fix (C.MemberAccess Fix (NodeF (Lexeme text))
expr Lexeme text
tname))  = [(Fix (NodeF (Lexeme text))
expr, Lexeme text -> text
forall text. Lexeme text -> text
lexemeText Lexeme text
tname)]
    extractGuards' (Fix (C.PointerAccess Fix (NodeF (Lexeme text))
expr Lexeme text
tname)) = [(Fix (NodeF (Lexeme text))
expr, Lexeme text -> text
forall text. Lexeme text -> text
lexemeText Lexeme text
tname)]
    extractGuards' (Fix (C.ParenExpr Fix (NodeF (Lexeme text))
e))              = Fix (NodeF (Lexeme text)) -> [(Fix (NodeF (Lexeme text)), text)]
extractGuards' Fix (NodeF (Lexeme text))
e
    extractGuards' Fix (NodeF (Lexeme text))
_                                  = []

    checkAccess :: String -> Node (Lexeme Text) -> Lexeme Text -> State LinterState ()
checkAccess String
file Node (Lexeme Text)
expr Lexeme Text
mname = do
        let mText :: Text
mText = Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
mname
        String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"checkAccess for member " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
mText String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in expression " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
expr
        case Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Text)
forall b.
Fix (NodeF (Lexeme b)) -> Maybe (Fix (NodeF (Lexeme b)), b)
extractUnionMember Node (Lexeme Text)
expr of
            Just (Node (Lexeme Text)
structExpr, Text
uName) -> do
                String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"Found union member candidate: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
uName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with structExpr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
structExpr
                LinterState
st <- StateT LinterState Identity LinterState
forall s (m :: * -> *). MonadState s m => m s
get
                let tName :: Maybe Text
tName = Map Text Text -> Node (Lexeme Text) -> Maybe Text
getTypeOf (LinterState -> Map Text Text
varTypes LinterState
st) Node (Lexeme Text)
structExpr
                String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"Type of structExpr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
tName
                case Maybe Text
tName of
                    Just Text
tn -> do
                        let matches :: [(Text, Text, Text, Text, Text, Text, [Text])]
matches = ((Text, Text, Text, Text, Text, Text, [Text]) -> Bool)
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [(Text, Text, Text, Text, Text, Text, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
sn, Text
um, Text
_, Text
_, Text
_, Text
_, [Text]
_) -> Text
sn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tn Bool -> Bool -> Bool
&& Text
um Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
uName) [(Text, Text, Text, Text, Text, Text, [Text])]
tagged
                        String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"Matches: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Text, Text, Text, Text, Text, Text, [Text])] -> String
forall a. Show a => a -> String
show [(Text, Text, Text, Text, Text, Text, [Text])]
matches
                        [(Text, Text, Text, Text, Text, Text, [Text])]
-> ((Text, Text, Text, Text, Text, Text, [Text])
    -> State LinterState ())
-> State LinterState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, Text, Text, Text, Text, Text, [Text])]
matches (((Text, Text, Text, Text, Text, Text, [Text])
  -> State LinterState ())
 -> State LinterState ())
-> ((Text, Text, Text, Text, Text, Text, [Text])
    -> State LinterState ())
-> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \(Text
_, Text
_, Text
tname, Text
_, Text
_, Text
prefix, [Text]
_) -> do
                            let checkedTags :: [[Text]]
checkedTags = Node (Lexeme Text)
-> Text -> [(Node (Lexeme Text), Text, [Text])] -> [[Text]]
forall b.
Node (Lexeme Text)
-> Text -> [(Node (Lexeme Text), Text, b)] -> [b]
findCheckedTags Node (Lexeme Text)
structExpr Text
tname (LinterState -> [(Node (Lexeme Text), Text, [Text])]
guards LinterState
st)
                            String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"Checking tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
tname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" against checkedTags " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [[Text]] -> String
forall a. Show a => a -> String
show [[Text]]
checkedTags
                            if [[Text]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
checkedTags
                            then do
                                String -> State LinterState ()
dtraceM String
"No check found"
                                String -> Lexeme Text -> Text -> State LinterState ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
mname (Text -> State LinterState ()) -> Text -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ Text
"access to union member `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not guarded by a check on `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
                            else do
                                let incorrect :: [[Text]]
incorrect = ([Text] -> Bool) -> [[Text]] -> [[Text]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Text -> Text -> Bool
isCorrectTag Text
prefix Text
mText)) [[Text]]
checkedTags
                                Bool -> State LinterState () -> State LinterState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [[Text]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Text]]
incorrect) (State LinterState () -> State LinterState ())
-> State LinterState () -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ do
                                    String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING: Incorrect tag(s): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [[Text]] -> String
forall a. Show a => a -> String
show [[Text]]
incorrect
                                    String -> Lexeme Text -> Text -> State LinterState ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file Lexeme Text
mname (Text -> State LinterState ()) -> Text -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ Text
"access to union member `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not guarded by a check on `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
expectedTag Text
mText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
                    Maybe Text
Nothing -> String -> State LinterState ()
dtraceM (String -> State LinterState ()) -> String -> State LinterState ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown struct type for member access: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
uName
            Maybe (Node (Lexeme Text), Text)
Nothing -> String -> State LinterState ()
dtraceM String
"Not a union member access"

    extractUnionMember :: Fix (NodeF (Lexeme b)) -> Maybe (Fix (NodeF (Lexeme b)), b)
extractUnionMember (Fix (C.MemberAccess Fix (NodeF (Lexeme b))
expr Lexeme b
uName)) =
        case Fix (NodeF (Lexeme b)) -> NodeF (Lexeme b) (Fix (NodeF (Lexeme b)))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Fix (NodeF (Lexeme b))
expr of
            C.MemberAccess Fix (NodeF (Lexeme b))
structExpr Lexeme b
_  -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
structExpr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
            C.PointerAccess Fix (NodeF (Lexeme b))
structExpr Lexeme b
_ -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
structExpr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
            NodeF (Lexeme b) (Fix (NodeF (Lexeme b)))
_                            -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
expr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
    extractUnionMember (Fix (C.PointerAccess Fix (NodeF (Lexeme b))
expr Lexeme b
uName)) =
        case Fix (NodeF (Lexeme b)) -> NodeF (Lexeme b) (Fix (NodeF (Lexeme b)))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Fix (NodeF (Lexeme b))
expr of
            C.MemberAccess Fix (NodeF (Lexeme b))
structExpr Lexeme b
_  -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
structExpr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
            C.PointerAccess Fix (NodeF (Lexeme b))
structExpr Lexeme b
_ -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
structExpr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
            NodeF (Lexeme b) (Fix (NodeF (Lexeme b)))
_                            -> (Fix (NodeF (Lexeme b)), b) -> Maybe (Fix (NodeF (Lexeme b)), b)
forall a. a -> Maybe a
Just (Fix (NodeF (Lexeme b))
expr, Lexeme b -> b
forall text. Lexeme text -> text
lexemeText Lexeme b
uName)
    extractUnionMember Fix (NodeF (Lexeme b))
_ = Maybe (Fix (NodeF (Lexeme b)), b)
forall a. Maybe a
Nothing

    findCheckedTags :: Node (Lexeme Text)
-> Text -> [(Node (Lexeme Text), Text, b)] -> [b]
findCheckedTags Node (Lexeme Text)
structExpr Text
tname [(Node (Lexeme Text), Text, b)]
gs =
        let cExpr :: Node (Lexeme Text)
cExpr = Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
structExpr
        in String -> [b] -> [b]
forall a. String -> a -> a
dtrace (String
"findCheckedTags: structExpr=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
cExpr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tname=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
tname) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$
           ((Node (Lexeme Text), Text, b) -> b)
-> [(Node (Lexeme Text), Text, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node (Lexeme Text)
_, Text
_, b
vals) -> b
vals) ([(Node (Lexeme Text), Text, b)] -> [b])
-> [(Node (Lexeme Text), Text, b)] -> [b]
forall a b. (a -> b) -> a -> b
$ ((Node (Lexeme Text), Text, b) -> Bool)
-> [(Node (Lexeme Text), Text, b)]
-> [(Node (Lexeme Text), Text, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Node (Lexeme Text)
gExpr, Text
gTname, b
_) -> Text
gTname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tname Bool -> Bool -> Bool
&& Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
gExpr Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Node (Lexeme Text)
cExpr) [(Node (Lexeme Text), Text, b)]
gs

    canonical :: Node (C.Lexeme Text) -> Node (C.Lexeme Text)
    canonical :: Node (Lexeme Text) -> Node (Lexeme Text)
canonical (Fix (C.ParenExpr Node (Lexeme Text)
e)) = Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
e
    canonical (Fix (C.VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
C.VarExpr (AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar Text
v))
    canonical (Fix (C.MemberAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
m))) = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
C.MemberAccess (Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
e) (AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar Text
m))
    canonical (Fix (C.PointerAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
m))) = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> lexeme -> NodeF lexeme a
C.PointerAccess (Node (Lexeme Text) -> Node (Lexeme Text)
canonical Node (Lexeme Text)
e) (AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar Text
m))
    canonical (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Node (Lexeme Text) -> Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node (Lexeme Text) -> Node (Lexeme Text)
canonical NodeF (Lexeme Text) (Node (Lexeme Text))
n)

    expectedTag :: Text -> Text
expectedTag Text
mText = Text
"TAG_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.toUpper Text
mText -- Heuristic for error message



analyse :: [(FilePath, [Node (C.Lexeme Text)])] -> [Text]
analyse :: [(String, [Node (Lexeme Text)])] -> [Text]
analyse [(String, [Node (Lexeme Text)])]
sources =
    let ts :: TypeSystem
ts = [(String, [Node (Lexeme Text)])] -> TypeSystem
collect [(String, [Node (Lexeme Text)])]
sources
        tagged :: [(Text, Text, Text, Text, Text, Text, [Text])]
tagged = TypeSystem -> [(Text, Text, Text, Text, Text, Text, [Text])]
findTaggedUnions TypeSystem
ts
        untaggedNames :: [Text]
untaggedNames = ((Text, Lexeme Text) -> Text) -> [(Text, Lexeme Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Lexeme Text) -> Text
forall a b. (a, b) -> a
fst ([(Text, Lexeme Text)] -> [Text])
-> [(Text, Lexeme Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ TypeSystem -> [(Text, Lexeme Text)]
findUntaggedUnions TypeSystem
ts

        linterM :: State LinterState ()
linterM = [(String, [Node (Lexeme Text)])]
-> ((String, [Node (Lexeme Text)]) -> State LinterState ())
-> State LinterState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [Node (Lexeme Text)])]
sources (((String, [Node (Lexeme Text)]) -> State LinterState ())
 -> State LinterState ())
-> ((String, [Node (Lexeme Text)]) -> State LinterState ())
-> State LinterState ()
forall a b. (a -> b) -> a -> b
$ \(String, [Node (Lexeme Text)])
tu -> AstActions (State LinterState) Text
-> (String, [Node (Lexeme Text)]) -> State LinterState ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst (TypeSystem
-> [(Text, Text, Text, Text, Text, Text, [Text])]
-> [Text]
-> AstActions (State LinterState) Text
linter TypeSystem
ts [(Text, Text, Text, Text, Text, Text, [Text])]
tagged [Text]
untaggedNames) ([String]
-> (String, [Node (Lexeme Text)]) -> (String, [Node (Lexeme Text)])
Common.skip [String
"third_party/cmp/cmp.h"] (String, [Node (Lexeme Text)])
tu)

        finalState :: LinterState
finalState = State LinterState () -> LinterState -> LinterState
forall s a. State s a -> s -> s
execState State LinterState ()
linterM ([(Node (Lexeme Text), Text, [Text])]
-> [Text] -> Map Text Text -> LinterState
LinterState [] [] Map Text Text
forall k a. Map k a
Map.empty)
    in [Text] -> [Text]
forall a. [a] -> [a]
reverse (LinterState -> [Text]
warnings LinterState
finalState)

descr :: ([(FilePath, [Node (C.Lexeme Text)])] -> [Text], (Text, Text))
descr :: ([(String, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr = ([(String, [Node (Lexeme Text)])] -> [Text]
analyse, (Text
"tagged-union", [Text] -> Text
Text.unlines
    [ Text
"Checks that all unions with incompatible types (pointers) in them are tagged,"
    , Text
"and when accessing their members, the tag is checked."
    ]))