{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
-- | The functions a call through a function pointer field may reach.
module Tokstyle.Cimple.Analysis.FunctionPointers
    ( Targets (..)
    , FieldKey
    , FieldTargets
    , fieldTargets
    , callTargets
    ) where

import           Data.Fix                           (Fix (..))
import qualified Data.List                          as List
import           Data.Map.Strict                    (Map)
import qualified Data.Map.Strict                    as Map
import           Data.Maybe                         (isJust)
import           Data.Set                           (Set)
import qualified Data.Set                           as Set
import           Data.Text                          (Text)
import qualified Data.Text                          as Text
import           Language.Cimple                    (Lexeme (..), NodeF (..),
                                                     UnaryOp (..))
import qualified Language.Cimple                    as C
import           Tokstyle.Cimple.Analysis.Functions (Function (..), constName,
                                                     definitions, localDecls,
                                                     universe, valuesUsed)
import           Tokstyle.Cimple.Analysis.Types     (Structs, bare,
                                                     callbackType, structName,
                                                     structs, typeIn)
import           Tokstyle.Common                    (isPublicHeader)


data Targets
    = Only (Set Text)
    -- ^ One of these functions, or null.
    | Anything (Set Text)
    -- ^ One of these, or anything a client stores.
    deriving (Targets -> Targets -> Bool
(Targets -> Targets -> Bool)
-> (Targets -> Targets -> Bool) -> Eq Targets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Targets -> Targets -> Bool
== :: Targets -> Targets -> Bool
$c/= :: Targets -> Targets -> Bool
/= :: Targets -> Targets -> Bool
Eq, Int -> Targets -> ShowS
[Targets] -> ShowS
Targets -> String
(Int -> Targets -> ShowS)
-> (Targets -> String) -> ([Targets] -> ShowS) -> Show Targets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Targets -> ShowS
showsPrec :: Int -> Targets -> ShowS
$cshow :: Targets -> String
show :: Targets -> String
$cshowList :: [Targets] -> ShowS
showList :: [Targets] -> ShowS
Show)

instance Semigroup Targets where
    Targets
a <> :: Targets -> Targets -> Targets
<> Targets
b = case (Targets
a, Targets
b) of
        (Only Set Text
x, Only Set Text
y) -> Set Text -> Targets
Only (Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
x Set Text
y)
        (Targets, Targets)
_                -> Set Text -> Targets
Anything (Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Targets -> Set Text
known Targets
a) (Targets -> Set Text
known Targets
b))
      where
        known :: Targets -> Set Text
known (Only Set Text
x)     = Set Text
x
        known (Anything Set Text
x) = Set Text
x

-- | A struct and one of its fields.
type FieldKey = (Text, Text)

type FieldTargets = Map FieldKey Targets

-- | A function and the index of one of its parameters.
type ParamKey = (Text, Int)

-- | Where a stored value comes from.
data Source
    = Value Targets
    | FromField FieldKey
    | FromParam ParamKey

-- | The functions code stores in each field, also via other fields and
-- parameters. Fields clients can set, or that get something we can't follow,
-- may hold anything.
fieldTargets :: [(FilePath, [C.Node (Lexeme Text)])] -> FieldTargets
fieldTargets :: [(String, [Node (Lexeme Text)])] -> FieldTargets
fieldTargets [(String, [Node (Lexeme Text)])]
tus = [((Text, Text), Targets)] -> FieldTargets
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((Text, Text)
k, Targets
t) | (Left (Text, Text)
k, Targets
t) <- Map (Either (Text, Text) ParamKey) Targets
-> [(Either (Text, Text) ParamKey, Targets)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Either (Text, Text) ParamKey) Targets
resolved ]
  where
    resolved :: Map (Either (Text, Text) ParamKey) Targets
resolved = Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) Targets
solveSources (([Source] -> [Source] -> [Source])
-> [(Either (Text, Text) ParamKey, [Source])]
-> Map (Either (Text, Text) ParamKey) [Source]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Source] -> [Source] -> [Source]
forall a. [a] -> [a] -> [a]
(++)
        [ ((Text, Text) -> Either (Text, Text) ParamKey
forall a b. a -> Either a b
Left (Text, Text)
k, [Source
src]) | ((Text, Text)
k, Source
src) <- [((Text, Text), Source)]
public [((Text, Text), Source)]
-> [((Text, Text), Source)] -> [((Text, Text), Source)]
forall a. [a] -> [a] -> [a]
++ [((Text, Text), Source)]
initialised [((Text, Text), Source)]
-> [((Text, Text), Source)] -> [((Text, Text), Source)]
forall a. [a] -> [a] -> [a]
++ [((Text, Text), Source)]
assigned ]
        Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) [Source]
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` ([Source] -> [Source] -> [Source])
-> [(Either (Text, Text) ParamKey, [Source])]
-> Map (Either (Text, Text) ParamKey) [Source]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Source] -> [Source] -> [Source]
forall a. [a] -> [a] -> [a]
(++) [ (ParamKey -> Either (Text, Text) ParamKey
forall a b. b -> Either a b
Right ParamKey
k, [Source
src]) | (ParamKey
k, Source
src) <- [(ParamKey, Source)]
passed ])

    types :: Structs
types = [(String, [Node (Lexeme Text)])] -> Structs
structs [(String, [Node (Lexeme Text)])]
tus
    order :: Map Text [Text]
order = [(String, [Node (Lexeme Text)])] -> Map Text [Text]
fieldOrder [(String, [Node (Lexeme Text)])]
tus
    fns :: [Function]
fns = [(String, [Node (Lexeme Text)])] -> [Function]
definitions [(String, [Node (Lexeme Text)])]
tus
    functions :: Set Text
functions = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
            FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ -> [Text
name]
            FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_))   -> [Text
name]
            NodeF (Lexeme Text) (Node (Lexeme Text))
_                                                         -> []
        | (String
_, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node ]
    isCallback :: Text -> Text -> Bool
isCallback Text
s Text
f = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Text -> Structs -> Maybe (Map Text (Node (Lexeme Text)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
s Structs
types Maybe (Map Text (Node (Lexeme Text)))
-> (Map Text (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text)))
-> Maybe (Node (Lexeme Text))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Map Text (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
f Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
callbackType)
    clientFile :: String -> Bool
clientFile String
file = String -> Bool
isPublicHeader String
file Bool -> Bool -> Bool
|| String
"tox_private.h" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` String
file

    -- Clients set the structs in public headers and @tox_private.h@.
    public :: [((Text, Text), Source)]
public =
        [ ((Text
s, Text
f), Targets -> Source
Value (Set Text -> Targets
Anything Set Text
forall a. Set a
Set.empty))
        | (String
file, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, String -> Bool
clientFile String
file
        , Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node
        , Text
s <- case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
            Struct (L AlexPosn
_ LexemeClass
_ Text
s') [Node (Lexeme Text)]
_                     -> [Text
s']
            Typedef (Fix (Struct Lexeme Text
_ [Node (Lexeme Text)]
_)) (L AlexPosn
_ LexemeClass
_ Text
s') [Node (Lexeme Text)]
_ -> [Text
s']
            NodeF (Lexeme Text) (Node (Lexeme Text))
_                                       -> []
        , Text
f <- Map Text (Node (Lexeme Text)) -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text (Node (Lexeme Text))
-> Text -> Structs -> Map Text (Node (Lexeme Text))
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Text (Node (Lexeme Text))
forall k a. Map k a
Map.empty Text
s Structs
types), Text -> Text -> Bool
isCallback Text
s Text
f ]

    source :: Maybe Function -> Node (Lexeme Text) -> Source
source Maybe Function
fn Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
        Fix (UnaryExpr UnaryOp
UopAddress f :: Node (Lexeme Text)
f@(Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
g)))) | Text
g Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
functions -> Maybe Function -> Node (Lexeme Text) -> Source
source Maybe Function
fn Node (Lexeme Text)
f
        Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
g))
            | Just Function
fn' <- Maybe Function
fn, Just Int
i <- Text -> [Text] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
g (Function -> [Text]
fnParams Function
fn') -> ParamKey -> Source
FromParam (Function -> Text
fnName Function
fn', Int
i)
            | Just Function
fn' <- Maybe Function
fn, Text
g Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String -> Text
Text.pack String
v | (String
v, Maybe (Node (Lexeme Text))
_) <- Node (Lexeme Text) -> [(String, Maybe (Node (Lexeme Text)))]
localDecls (Function -> Node (Lexeme Text)
fnDefn Function
fn') ] -> Targets -> Source
Value (Set Text -> Targets
Anything Set Text
forall a. Set a
Set.empty)
            | Text
g Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
functions -> Targets -> Source
Value (Set Text -> Targets
Only (Text -> Set Text
forall a. a -> Set a
Set.singleton Text
g))
        Node (Lexeme Text)
e' | Node (Lexeme Text) -> Maybe Text
constName Node (Lexeme Text)
e' Maybe Text -> [Maybe Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"nullptr", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"NULL"] -> Targets -> Source
Value (Set Text -> Targets
Only Set Text
forall a. Set a
Set.empty)
        Node (Lexeme Text)
e' | Just Function
fn' <- Maybe Function
fn, Just (Node (Lexeme Text)
x, Text
g) <- Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Text)
fieldOf Node (Lexeme Text)
e'
           , Just Text
s <- Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn' Node (Lexeme Text)
x Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName, Text -> Text -> Bool
isCallback Text
s Text
g -> (Text, Text) -> Source
FromField (Text
s, Text
g)
        Node (Lexeme Text)
_ -> Targets -> Source
Value (Set Text -> Targets
Anything Set Text
forall a. Set a
Set.empty)

    initialised :: [((Text, Text), Source)]
initialised = [[((Text, Text), Source)]] -> [((Text, Text), Source)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Text -> [Node (Lexeme Text)] -> [((Text, Text), Source)]
initList Text
s [Node (Lexeme Text)]
vals
        | (String
_, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node
        , (Node (Lexeme Text)
ty, Fix (InitialiserList [Node (Lexeme Text)]
vals)) <- case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
            ConstDefn Scope
_ Node (Lexeme Text)
t Lexeme Text
_ Node (Lexeme Text)
v                          -> [(Node (Lexeme Text)
t, Node (Lexeme Text)
v)]
            VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
t Lexeme Text
_ [Node (Lexeme Text)]
_)) (Just Node (Lexeme Text)
v) -> [(Node (Lexeme Text)
t, Node (Lexeme Text)
v)]
            CompoundLiteral Node (Lexeme Text)
t Node (Lexeme Text)
v                        -> [(Node (Lexeme Text)
t, Node (Lexeme Text)
v)]
            NodeF (Lexeme Text) (Node (Lexeme Text))
_                                          -> []
        , Just Text
s <- [Node (Lexeme Text) -> Maybe Text
structName Node (Lexeme Text)
ty] ]
    initList :: Text -> [Node (Lexeme Text)] -> [((Text, Text), Source)]
initList Text
s [Node (Lexeme Text)]
vals = [[((Text, Text), Source)]] -> [((Text, Text), Source)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case Node (Lexeme Text)
v of
            Fix (InitialiserList [Node (Lexeme Text)]
inner) | Just Text
s' <- Text -> Structs -> Maybe (Map Text (Node (Lexeme Text)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
s Structs
types Maybe (Map Text (Node (Lexeme Text)))
-> (Map Text (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text)))
-> Maybe (Node (Lexeme Text))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Map Text (Node (Lexeme Text)) -> Maybe (Node (Lexeme Text))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
f Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName ->
                Text -> [Node (Lexeme Text)] -> [((Text, Text), Source)]
initList Text
s' [Node (Lexeme Text)]
inner
            Node (Lexeme Text)
_ | Text -> Text -> Bool
isCallback Text
s Text
f -> [((Text
s, Text
f), Maybe Function -> Node (Lexeme Text) -> Source
source Maybe Function
forall a. Maybe a
Nothing Node (Lexeme Text)
v)]
            Node (Lexeme Text)
_                  -> []
        | (Text
f, Node (Lexeme Text)
v) <- [Text] -> [Node (Lexeme Text)] -> [(Text, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Text] -> Text -> Map Text [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Text
s Map Text [Text]
order) [Node (Lexeme Text)]
vals ]

    assigned :: [((Text, Text), Source)]
assigned =
        [ ((Text, Text), Source)
store
        | Function
fn <- [Function]
fns
        , Fix (AssignExpr Node (Lexeme Text)
l AssignOp
_ Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn)
        , Just (Node (Lexeme Text)
x, Text
f) <- [Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Text)
fieldOf Node (Lexeme Text)
l]
        , ((Text, Text), Source)
store <- case Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn Node (Lexeme Text)
x Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName of
            Just Text
s | Text -> Text -> Bool
isCallback Text
s Text
f -> [((Text
s, Text
f), Maybe Function -> Node (Lexeme Text) -> Source
source (Function -> Maybe Function
forall a. a -> Maybe a
Just Function
fn) Node (Lexeme Text)
r)]
                   | Bool
otherwise      -> []
            -- We don't know the struct, so any with this callback field may
            -- hold anything.
            Maybe Text
Nothing -> [ ((Text
s, Text
f), Targets -> Source
Value (Set Text -> Targets
Anything Set Text
forall a. Set a
Set.empty)) | Text
s <- Structs -> [Text]
forall k a. Map k a -> [k]
Map.keys Structs
types, Text -> Text -> Bool
isCallback Text
s Text
f ]
        ]

    -- Public functions and functions used as values may get anything.
    passed :: [(ParamKey, Source)]
passed =
        [ ((Function -> Text
fnName Function
callee, Int
i), Maybe Function -> Node (Lexeme Text) -> Source
source (Function -> Maybe Function
forall a. a -> Maybe a
Just Function
fn) Node (Lexeme Text)
a)
        | Function
fn <- [Function]
fns
        , Fix (FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
g))) [Node (Lexeme Text)]
args) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn)
        , Just Function
callee <- [Text -> Map Text Function -> Maybe Function
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g Map Text Function
byName]
        , (Int
i, Node (Lexeme Text)
a) <- [Int] -> [Node (Lexeme Text)] -> [(Int, Node (Lexeme Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Node (Lexeme Text)]
args ]
        [(ParamKey, Source)]
-> [(ParamKey, Source)] -> [(ParamKey, Source)]
forall a. [a] -> [a] -> [a]
++ [ ((Function -> Text
fnName Function
f, Int
i), Targets -> Source
Value (Set Text -> Targets
Anything Set Text
forall a. Set a
Set.empty))
           | Function
f <- [Function]
fns, Function -> Text
fnName Function
f Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
open, Int
i <- [Int
0 .. [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Function -> [Text]
fnParams Function
f) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
    byName :: Map Text Function
byName = [(Text, Function)] -> Map Text Function
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Function -> Text
fnName Function
f, Function
f) | Function
f <- [Function]
fns ]
    open :: Set Text
open = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
clientCalled Set Text
usedAsValue
    clientCalled :: Set Text
clientCalled = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Text
name
        | (String
file, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, String -> Bool
clientFile String
file, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes
        , Fix (FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_))) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node ]
    usedAsValue :: Set Text
usedAsValue = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Text
g | (String
_, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Text
g <- Node (Lexeme Text) -> [Text]
valuesUsed Node (Lexeme Text)
node, Text
g Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
functions ]

solveSources :: Map (Either FieldKey ParamKey) [Source] -> Map (Either FieldKey ParamKey) Targets
solveSources :: Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) Targets
solveSources Map (Either (Text, Text) ParamKey) [Source]
sources = Map (Either (Text, Text) ParamKey) Targets
-> Map (Either (Text, Text) ParamKey) Targets
go (([Source] -> Targets)
-> Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) Targets
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Targets -> [Source] -> Targets
forall a b. a -> b -> a
const (Set Text -> Targets
Only Set Text
forall a. Set a
Set.empty)) Map (Either (Text, Text) ParamKey) [Source]
sources)
  where
    go :: Map (Either (Text, Text) ParamKey) Targets
-> Map (Either (Text, Text) ParamKey) Targets
go Map (Either (Text, Text) ParamKey) Targets
known =
        let known' :: Map (Either (Text, Text) ParamKey) Targets
known' = ([Source] -> Targets)
-> Map (Either (Text, Text) ParamKey) [Source]
-> Map (Either (Text, Text) ParamKey) Targets
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Source -> Targets -> Targets) -> Targets -> [Source] -> Targets
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Targets -> Targets -> Targets
forall a. Semigroup a => a -> a -> a
(<>) (Targets -> Targets -> Targets)
-> (Source -> Targets) -> Source -> Targets -> Targets
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Either (Text, Text) ParamKey) Targets -> Source -> Targets
look Map (Either (Text, Text) ParamKey) Targets
known) (Set Text -> Targets
Only Set Text
forall a. Set a
Set.empty)) Map (Either (Text, Text) ParamKey) [Source]
sources
        in if Map (Either (Text, Text) ParamKey) Targets
known' Map (Either (Text, Text) ParamKey) Targets
-> Map (Either (Text, Text) ParamKey) Targets -> Bool
forall a. Eq a => a -> a -> Bool
== Map (Either (Text, Text) ParamKey) Targets
known then Map (Either (Text, Text) ParamKey) Targets
known else Map (Either (Text, Text) ParamKey) Targets
-> Map (Either (Text, Text) ParamKey) Targets
go Map (Either (Text, Text) ParamKey) Targets
known'
    look :: Map (Either (Text, Text) ParamKey) Targets -> Source -> Targets
look Map (Either (Text, Text) ParamKey) Targets
known = \case
        Value Targets
t     -> Targets
t
        FromField (Text, Text)
k -> Targets
-> Either (Text, Text) ParamKey
-> Map (Either (Text, Text) ParamKey) Targets
-> Targets
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Set Text -> Targets
Only Set Text
forall a. Set a
Set.empty) ((Text, Text) -> Either (Text, Text) ParamKey
forall a b. a -> Either a b
Left (Text, Text)
k) Map (Either (Text, Text) ParamKey) Targets
known
        FromParam ParamKey
k -> Targets
-> Either (Text, Text) ParamKey
-> Map (Either (Text, Text) ParamKey) Targets
-> Targets
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Set Text -> Targets
Only Set Text
forall a. Set a
Set.empty) (ParamKey -> Either (Text, Text) ParamKey
forall a b. b -> Either a b
Right ParamKey
k) Map (Either (Text, Text) ParamKey) Targets
known

fieldOf :: C.Node (Lexeme Text) -> Maybe (C.Node (Lexeme Text), Text)
fieldOf :: Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Text)
fieldOf Node (Lexeme Text)
e = case Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e of
    Fix (PointerAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f)) -> (Node (Lexeme Text), Text) -> Maybe (Node (Lexeme Text), Text)
forall a. a -> Maybe a
Just (Node (Lexeme Text)
x, Text
f)
    Fix (MemberAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f))  -> (Node (Lexeme Text), Text) -> Maybe (Node (Lexeme Text), Text)
forall a. a -> Maybe a
Just (Node (Lexeme Text)
x, Text
f)
    Node (Lexeme Text)
_                               -> Maybe (Node (Lexeme Text), Text)
forall a. Maybe a
Nothing

fieldOrder :: [(FilePath, [C.Node (Lexeme Text)])] -> Map Text [Text]
fieldOrder :: [(String, [Node (Lexeme Text)])] -> Map Text [Text]
fieldOrder [(String, [Node (Lexeme Text)])]
tus = [(Text, [Text])] -> Map Text [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
name, [ Text
f | Fix (MemberDecl (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
f) [Node (Lexeme Text)]
_)) Maybe (Lexeme Text)
_) <- [Node (Lexeme Text)]
members ])
    | (String
_, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node
    , (Text
name, [Node (Lexeme Text)]
members) <- case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
        Struct (L AlexPosn
_ LexemeClass
_ Text
s) [Node (Lexeme Text)]
ms                     -> [(Text
s, [Node (Lexeme Text)]
ms)]
        Typedef (Fix (Struct Lexeme Text
_ [Node (Lexeme Text)]
ms)) (L AlexPosn
_ LexemeClass
_ Text
s) [Node (Lexeme Text)]
_ -> [(Text
s, [Node (Lexeme Text)]
ms)]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                                       -> []
    ]

callTargets :: Structs -> FieldTargets -> Function -> C.Node (Lexeme Text) -> Maybe Targets
callTargets :: Structs
-> FieldTargets -> Function -> Node (Lexeme Text) -> Maybe Targets
callTargets Structs
types FieldTargets
targets Function
fn Node (Lexeme Text)
callee = do
    (Node (Lexeme Text)
x, Text
f) <- Node (Lexeme Text) -> Maybe (Node (Lexeme Text), Text)
fieldOf Node (Lexeme Text)
callee
    Text
s <- Structs
-> Function -> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
typeIn Structs
types Function
fn Node (Lexeme Text)
x Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node (Lexeme Text) -> Maybe Text
structName
    (Text, Text) -> FieldTargets -> Maybe Targets
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text
s, Text
f) FieldTargets
targets