{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
-- | Inference of destructors: functions that free their arguments.
module Tokstyle.Cimple.Analysis.Destructors
    ( Destructors
    , destructors
    , destroyed
    ) 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                         (isNothing)
import           Data.Set                           (Set)
import qualified Data.Set                           as Set
import           Data.Text                          (Text)
import qualified Data.Text                          as Text
import           Language.Cimple                    (BinaryOp (..), Lexeme (..),
                                                     NodeF (..), UnaryOp (..))
import qualified Language.Cimple                    as C
import           Tokstyle.Analysis.Dataflow         (Dataflow (..), solve)
import           Tokstyle.Cimple.Analysis.CFG       (EdgeType (..), Node (..),
                                                     NodeKind (..),
                                                     fromFunction)
import           Tokstyle.Cimple.Analysis.Functions


data Destroys = All | Fields (Set Text)
    deriving (Destroys -> Destroys -> Bool
(Destroys -> Destroys -> Bool)
-> (Destroys -> Destroys -> Bool) -> Eq Destroys
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Destroys -> Destroys -> Bool
== :: Destroys -> Destroys -> Bool
$c/= :: Destroys -> Destroys -> Bool
/= :: Destroys -> Destroys -> Bool
Eq)

type Destructors = Map Text Done

-- | Get the arguments a call destroys, wholly or partly.
destroyed :: Destructors -> C.Node (Lexeme Text) -> [C.Node (Lexeme Text)]
destroyed :: Destructors -> Node (Lexeme Text) -> [Node (Lexeme Text)]
destroyed Destructors
ds Node (Lexeme Text)
e = ((Destroys, Node (Lexeme Text)) -> Node (Lexeme Text))
-> [(Destroys, Node (Lexeme Text))] -> [Node (Lexeme Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Destroys, Node (Lexeme Text)) -> Node (Lexeme Text)
forall a b. (a, b) -> b
snd (Destructors
-> Node (Lexeme Text) -> [(Destroys, Node (Lexeme Text))]
destroyedBy Destructors
ds Node (Lexeme Text)
e)

destroyedBy :: Destructors -> C.Node (Lexeme Text) -> [(Destroys, C.Node (Lexeme Text))]
destroyedBy :: Destructors
-> Node (Lexeme Text) -> [(Destroys, Node (Lexeme Text))]
destroyedBy Destructors
ds Node (Lexeme Text)
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
e) of
    FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
args | L AlexPosn
_ LexemeClass
_ Text
g <- Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee, Just Done
ps <- Text -> Destructors -> Maybe Done
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
g Destructors
ds ->
        [ (Destroys
d, Node (Lexeme Text)
a) | (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, Just Destroys
d <- [Int -> Done -> Maybe Destroys
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i Done
ps] ]
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> []

-- | Infer the destructors of a program: functions that destroy a parameter or
-- some of its fields on every exit except failure returns.
destructors :: [(FilePath, [C.Node (Lexeme Text)])] -> Destructors
destructors :: [(FilePath, [Node (Lexeme Text)])] -> Destructors
destructors [(FilePath, [Node (Lexeme Text)])]
tus = (Function -> [Text])
-> (Destructors -> Function -> Destructors)
-> (Destructors -> Function -> Maybe Done)
-> [Function]
-> Destructors
-> Destructors
forall k s.
Eq k =>
(Function -> [Text])
-> (s -> Function -> s)
-> (s -> Function -> k)
-> [Function]
-> s
-> s
bottomUp Function -> [Text]
callees Destructors -> Function -> Destructors
add Destructors -> Function -> Maybe Done
forall {a}. Map Text a -> Function -> Maybe a
look ([(FilePath, [Node (Lexeme Text)])] -> [Function]
definitions [(FilePath, [Node (Lexeme Text)])]
tus) ((Int -> Done) -> Map Text Int -> Destructors
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int -> Destroys -> Done
forall k a. k -> a -> Map k a
`Map.singleton` Destroys
All) Map Text Int
freers)
  where
    add :: Destructors -> Function -> Destructors
add Destructors
ds Function
f
        | Done -> Bool
forall k a. Map k a -> Bool
Map.null Done
ps = Destructors
ds
        | Bool
otherwise   = Text -> Done -> Destructors -> Destructors
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Function -> Text
fnName Function
f) Done
ps Destructors
ds
      where ps :: Done
ps = Destructors -> Function -> Done
destroys Destructors
ds Function
f
    look :: Map Text a -> Function -> Maybe a
look Map Text a
ds Function
f = Text -> Map Text a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Function -> Text
fnName Function
f) Map Text a
ds

-- | Dataflow state: what every path to a node has destroyed of each
-- parameter.
type Done = Map Int Destroys

-- | Meet of two path states: what both paths destroyed.
meet :: Done -> Done -> Done
meet :: Done -> Done -> Done
meet = (Int -> Destroys -> Destroys -> Maybe Destroys)
-> (Done -> Done) -> (Done -> Done) -> Done -> Done -> Done
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey (\Int
_ Destroys
a Destroys
b -> Destroys -> Destroys -> Maybe Destroys
both Destroys
a Destroys
b) (Done -> Done -> Done
forall a b. a -> b -> a
const Done
forall k a. Map k a
Map.empty) (Done -> Done -> Done
forall a b. a -> b -> a
const Done
forall k a. Map k a
Map.empty)
  where
    both :: Destroys -> Destroys -> Maybe Destroys
both Destroys
All Destroys
d                     = Destroys -> Maybe Destroys
forall a. a -> Maybe a
Just Destroys
d
    both Destroys
d Destroys
All                     = Destroys -> Maybe Destroys
forall a. a -> Maybe a
Just Destroys
d
    both (Fields Set Text
a) (Fields Set Text
b)
        | Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
c = Maybe Destroys
forall a. Maybe a
Nothing
        | Bool
otherwise  = Destroys -> Maybe Destroys
forall a. a -> Maybe a
Just (Set Text -> Destroys
Fields Set Text
c)
      where c :: Set Text
c = Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Text
a Set Text
b

destroy :: Part -> Done -> Done
destroy :: Part -> Done -> Done
destroy = \case
    Whole Int
i   -> Int -> Destroys -> Done -> Done
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i Destroys
All
    Field Int
i Text
f -> (Destroys -> Destroys -> Destroys)
-> Int -> Destroys -> Done -> Done
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Destroys -> Destroys -> Destroys
more Int
i (Set Text -> Destroys
Fields (Text -> Set Text
forall a. a -> Set a
Set.singleton Text
f))
  where
    more :: Destroys -> Destroys -> Destroys
more Destroys
_ Destroys
All                 = Destroys
All
    more (Fields Set Text
a) (Fields Set Text
b) = Set Text -> Destroys
Fields (Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Text
a Set Text
b)
    more Destroys
All Destroys
_                 = Destroys
All

replace :: Part -> Done -> Done
replace :: Part -> Done -> Done
replace = \case
    Whole Int
i   -> Int -> Done -> Done
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
i
    Field Int
i Text
f -> (Destroys -> Maybe Destroys) -> Int -> Done -> Done
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Text -> Destroys -> Maybe Destroys
without Text
f) Int
i
  where
    without :: Text -> Destroys -> Maybe Destroys
without Text
_ Destroys
All = Destroys -> Maybe Destroys
forall a. a -> Maybe a
Just Destroys
All
    without Text
f (Fields Set Text
fs)
        | Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
fs' = Maybe Destroys
forall a. Maybe a
Nothing
        | Bool
otherwise    = Destroys -> Maybe Destroys
forall a. a -> Maybe a
Just (Set Text -> Destroys
Fields Set Text
fs')
      where fs' :: Set Text
fs' = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.delete Text
f Set Text
fs

destroys :: Destructors -> Function -> Done
destroys :: Destructors -> Function -> Done
destroys Destructors
ds Function
fn = case [Done]
ends of
    [] -> Done
forall k a. Map k a
Map.empty
    [Done]
_  -> (Done -> Done -> Done) -> [Done] -> Done
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
List.foldl1' Done -> Done -> Done
meet [Done]
ends
  where
    (Node
entry, CFG
cfg) = Node (Lexeme Text) -> (Node, CFG)
fromFunction (Function -> Node (Lexeme Text)
fnDefn Function
fn)
    params :: Map Text Int
params = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Function -> [Text]
fnParams Function
fn) [Int
0 ..])
    -- Locals only ever holding a parameter, e.g. @Foo *foo = (Foo *)user_data;@.
    aliases :: Map Text Int
aliases = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (FilePath -> Text
Text.pack FilePath
v, Int
i)
        | (FilePath
v, Just Node (Lexeme Text)
ini) <- Node (Lexeme Text) -> [(FilePath, Maybe (Node (Lexeme Text)))]
localDecls (Function -> Node (Lexeme Text)
fnDefn Function
fn)
        , [Node (Lexeme Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Node (Lexeme Text)]
-> FilePath
-> Map FilePath [Node (Lexeme Text)]
-> [Node (Lexeme Text)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] FilePath
v (Node (Lexeme Text) -> Map FilePath [Node (Lexeme Text)]
assignments (Function -> Node (Lexeme Text)
fnDefn Function
fn)))
        , Just Int
i <- [Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
params Node (Lexeme Text)
ini] ]
    vars :: Map Text Int
vars = Map Text Int -> Map Text Int -> Map Text Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text Int
params Map Text Int
aliases
    owner :: Node (Lexeme Text) -> Maybe Part
owner = Map Text Int -> Node (Lexeme Text) -> Maybe Part
partOf Map Text Int
vars
    under :: Node (Lexeme Text) -> Maybe Part
under = Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars

    step :: Node -> Done -> Done
step Node
n Done
done = (Done -> Node (Lexeme Text) -> Done)
-> Done -> [Node (Lexeme Text)] -> Done
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Node (Lexeme Text) -> Done -> Done)
-> Done -> Node (Lexeme Text) -> Done
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node (Lexeme Text) -> Done -> Done
expr) Done
done (Node -> [Node (Lexeme Text)]
nodeExprs Node
n)
    -- A field assigned new memory after it is freed was replaced, not
    -- destroyed.
    expr :: Node (Lexeme Text) -> Done -> Done
expr Node (Lexeme Text)
e Done
done = (Done -> Part -> Done) -> Done -> [Part] -> Done
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Part -> Done -> Done) -> Done -> Part -> Done
forall a b c. (a -> b -> c) -> b -> a -> c
flip Part -> Done -> Done
replace) ((Done -> Part -> Done) -> Done -> [Part] -> Done
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Part -> Done -> Done) -> Done -> Part -> Done
forall a b c. (a -> b -> c) -> b -> a -> c
flip Part -> Done -> Done
destroy) Done
done [Part]
gone) [Part]
replaced
      where
        gone :: [Part]
gone = [[Part]] -> [Part]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ Destroys -> Part -> [Part]
parts Destroys
d Part
p | Node (Lexeme Text)
c <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e, (Destroys
d, Node (Lexeme Text)
a) <- Destructors
-> Node (Lexeme Text) -> [(Destroys, Node (Lexeme Text))]
destroyedBy Destructors
ds Node (Lexeme Text)
c, Just Part
p <- [Node (Lexeme Text) -> Maybe Part
owner Node (Lexeme Text)
a] ]
        replaced :: [Part]
replaced =
            [ Part
p | Fix (AssignExpr Node (Lexeme Text)
l AssignOp
_ Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
e
                , Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Node (Lexeme Text) -> Maybe Text
constName Node (Lexeme Text)
r), Maybe Integer -> Bool
forall a. Maybe a -> Bool
isNothing (Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r), Just Part
p <- [Node (Lexeme Text) -> Maybe Part
under Node (Lexeme Text)
l] ]
    -- Map what a callee destroys of an argument to fields of the parameter
    -- passed as that argument.
    parts :: Destroys -> Part -> [Part]
parts Destroys
d Part
p = case (Destroys
d, Part
p) of
        (Fields Set Text
fs, Whole Int
i) -> [ Int -> Text -> Part
Field Int
i Text
f | Text
f <- Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
fs ]
        (Destroys, Part)
_                    -> [Part
p]
    -- A null pointer needs no destroying, so it counts as destroyed on the
    -- branch where it is null, e.g. both @a@ and @b@ on the true branch of
    -- @a == nullptr || b == nullptr@.
    edge :: Node -> EdgeType -> Done -> Done
edge Node
n EdgeType
e Done
done = case Node
n of
        Node Int
_ (BranchNode Node (Lexeme Text)
cond)
            | EdgeType
e EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
TrueBranch, Just [Part]
ps <- Node (Lexeme Text) -> Maybe [Part]
nullAmong Node (Lexeme Text)
cond -> (Done -> Part -> Done) -> Done -> [Part] -> Done
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Part -> Done -> Done) -> Done -> Part -> Done
forall a b c. (a -> b -> c) -> b -> a -> c
flip Part -> Done -> Done
destroy) Done
done [Part]
ps
            | Just (Part
p, EdgeType
nullOn) <- (Node (Lexeme Text) -> Maybe Part)
-> Node (Lexeme Text) -> Maybe (Part, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe Part
owner Node (Lexeme Text)
cond, EdgeType
nullOn EdgeType -> EdgeType -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeType
e -> Part -> Done -> Done
destroy Part
p Done
done
        Node
_ -> Done
done
    nullAmong :: Node (Lexeme Text) -> Maybe [Part]
nullAmong Node (Lexeme Text)
cond = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
cond) of
        BinaryExpr Node (Lexeme Text)
l BinaryOp
BopOr Node (Lexeme Text)
r -> [Part] -> [Part] -> [Part]
forall a. [a] -> [a] -> [a]
(++) ([Part] -> [Part] -> [Part])
-> Maybe [Part] -> Maybe ([Part] -> [Part])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe [Part]
nullAmong Node (Lexeme Text)
l Maybe ([Part] -> [Part]) -> Maybe [Part] -> Maybe [Part]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node (Lexeme Text) -> Maybe [Part]
nullAmong Node (Lexeme Text)
r
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ | Just (Part
p, EdgeType
TrueBranch) <- (Node (Lexeme Text) -> Maybe Part)
-> Node (Lexeme Text) -> Maybe (Part, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe Part
owner Node (Lexeme Text)
cond -> [Part] -> Maybe [Part]
forall a. a -> Maybe a
Just [Part
p]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe [Part]
forall a. Maybe a
Nothing

    result :: Map Node Done
result = Node -> CFG -> Dataflow Node EdgeType Done -> Map Node Done
forall node state edge.
(Ord node, Eq state) =>
node
-> Map node [(edge, node)]
-> Dataflow node edge state
-> Map node state
solve Node
entry CFG
cfg Dataflow
        { transfer :: Node -> Done -> Done
transfer     = Node -> Done -> Done
step
        , edgeTransfer :: Node -> EdgeType -> Done -> Done
edgeTransfer = Node -> EdgeType -> Done -> Done
edge
        , merge :: Done -> Done -> Done
merge        = Done -> Done -> Done
meet
        , initial :: Done
initial      = Done
forall k a. Map k a
Map.empty
        }

    ends :: [Done]
ends =
        [ Node -> EdgeType -> Done -> Done
edge Node
n EdgeType
e (Node -> Done -> Done
step Node
n Done
st)
        | (Node
n, [Edge]
out) <- CFG -> [(Node, [Edge])]
forall k a. Map k a -> [(k, a)]
Map.toList CFG
cfg
        , (EdgeType
e, Node Int
_ NodeKind
ExitNode) <- [Edge]
out
        , Bool -> Bool
not (Node -> Bool
failing Node
n)
        , Just Done
st <- [Node -> Map Node Done -> Maybe Done
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Node
n Map Node Done
result]
        ]
    failing :: Node -> Bool
failing = \case
        Node Int
_ (StmtNode (Fix (Return Maybe (Node (Lexeme Text))
e))) -> Shape -> Maybe (Node (Lexeme Text)) -> [Outcome]
returnOutcomes (Function -> Shape
fnShape Function
fn) Maybe (Node (Lexeme Text))
e [Outcome] -> [Outcome] -> Bool
forall a. Eq a => a -> a -> Bool
== [Outcome
Failure]
        Node
_                                  -> Bool
False

varIn :: Map Text Int -> C.Node (Lexeme Text) -> Maybe Int
varIn :: Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
e) of
    VarExpr (L AlexPosn
_ LexemeClass
_ Text
v) -> Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
v Map Text Int
vars
    CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
x      -> Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
x
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                 -> Maybe Int
forall a. Maybe a
Nothing

data Part = Whole Int | Field Int Text
    deriving (Part -> Part -> Bool
(Part -> Part -> Bool) -> (Part -> Part -> Bool) -> Eq Part
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Part -> Part -> Bool
== :: Part -> Part -> Bool
$c/= :: Part -> Part -> Bool
/= :: Part -> Part -> Bool
Eq, Eq Part
Eq Part =>
(Part -> Part -> Ordering)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Bool)
-> (Part -> Part -> Part)
-> (Part -> Part -> Part)
-> Ord Part
Part -> Part -> Bool
Part -> Part -> Ordering
Part -> Part -> Part
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Part -> Part -> Ordering
compare :: Part -> Part -> Ordering
$c< :: Part -> Part -> Bool
< :: Part -> Part -> Bool
$c<= :: Part -> Part -> Bool
<= :: Part -> Part -> Bool
$c> :: Part -> Part -> Bool
> :: Part -> Part -> Bool
$c>= :: Part -> Part -> Bool
>= :: Part -> Part -> Bool
$cmax :: Part -> Part -> Part
max :: Part -> Part -> Part
$cmin :: Part -> Part -> Part
min :: Part -> Part -> Part
Ord)

-- | Get the parameter or parameter field an expression names, looking
-- through casts and @&@.
partOf :: Map Text Int -> C.Node (Lexeme Text) -> Maybe Part
partOf :: Map Text Int -> Node (Lexeme Text) -> Maybe Part
partOf Map Text Int
vars Node (Lexeme Text)
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
e) of
    UnaryExpr UnaryOp
UopAddress Node (Lexeme Text)
x    -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
partOf Map Text Int
vars Node (Lexeme Text)
x
    CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
x              -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
partOf Map Text Int
vars Node (Lexeme Text)
x
    PointerAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f) -> (Int -> Text -> Part
`Field` Text
f) (Int -> Part) -> Maybe Int -> Maybe Part
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
x
    MemberAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f)  -> (Int -> Text -> Part
`Field` Text
f) (Int -> Part) -> Maybe Int -> Maybe Part
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
x
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                         -> Int -> Part
Whole (Int -> Part) -> Maybe Int -> Maybe Part
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
e

-- | Get the parameter, or its field, that an expression accesses at any
-- depth.
fieldUnder :: Map Text Int -> C.Node (Lexeme Text) -> Maybe Part
fieldUnder :: Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
e) of
    PointerAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f) | Just Int
i <- Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
x -> Part -> Maybe Part
forall a. a -> Maybe a
Just (Int -> Text -> Part
Field Int
i Text
f)
    MemberAccess Node (Lexeme Text)
x (L AlexPosn
_ LexemeClass
_ Text
f) | Just Int
i <- Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
x  -> Part -> Maybe Part
forall a. a -> Maybe a
Just (Int -> Text -> Part
Field Int
i Text
f)
    PointerAccess Node (Lexeme Text)
x Lexeme Text
_                                  -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
x
    MemberAccess Node (Lexeme Text)
x Lexeme Text
_                                   -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
x
    ArrayAccess Node (Lexeme Text)
x Node (Lexeme Text)
_                                    -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
x
    UnaryExpr UnaryOp
UopDeref Node (Lexeme Text)
x                               -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
x
    CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
x                                       -> Map Text Int -> Node (Lexeme Text) -> Maybe Part
fieldUnder Map Text Int
vars Node (Lexeme Text)
x
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                                                  -> Int -> Part
Whole (Int -> Part) -> Maybe Int -> Maybe Part
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Int -> Node (Lexeme Text) -> Maybe Int
varIn Map Text Int
vars Node (Lexeme Text)
e