{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
-- | Function definitions with their success conventions, and helpers for
-- analysing function bodies.
module Tokstyle.Cimple.Analysis.Functions
    ( Function (..)
    , Shape (..)
    , Outcome (..)
    , definitions
    , callees
    , bottomUp
    , freers
    , allocators
    , bare
    , accessPath
    , mapRoot
    , valuesUsed
    , returnOutcomes
    , branchOn
    , calleeLexeme
    , universe
    , strip
    , unFix'
    , intLit
    , constName
    , isNullLit
    , nullTest
    , isEnumConst
    , flagHolds
    , localDecls
    , assignments
    , nodeExprs
    , rootOf
    , throughPointer
    , render
    ) where

import           Data.Fix                     (Fix (..))
import qualified Data.Graph                   as Graph
import qualified Data.List                    as List
import           Data.Map.Strict              (Map)
import qualified Data.Map.Strict              as Map
import           Data.Maybe                   (mapMaybe)
import           Data.Text                    (Text)
import qualified Data.Text                    as Text
import           Language.Cimple              (BinaryOp (..), Lexeme (..),
                                               NodeF (..), UnaryOp (..))
import qualified Language.Cimple              as C
import           Language.Cimple.Pretty       (showNodePlain)
import           Prettyprinter                (Doc, pretty)
import           Tokstyle.Analysis.AccessPath (AccessPath (..))
import           Tokstyle.Cimple.Analysis.CFG (EdgeType (..), Node (..),
                                               NodeKind (..), getFuncName)


-- | The convention a function's return value uses to report success.
data Shape
    = BoolShape
    -- ^ Returns @true@ on success and @false@ on failure.
    | ZeroShape
    -- ^ Returns 0 on success and a negative number on failure.
    | IdShape
    -- ^ Returns a negative number on failure and anything else on success.
    | PtrShape
    -- ^ Returns @nullptr@ on failure.
    | NoShape

data Outcome = Success | Failure
    deriving (Outcome -> Outcome -> Bool
(Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool) -> Eq Outcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Outcome -> Outcome -> Bool
== :: Outcome -> Outcome -> Bool
$c/= :: Outcome -> Outcome -> Bool
/= :: Outcome -> Outcome -> Bool
Eq, Eq Outcome
Eq Outcome =>
(Outcome -> Outcome -> Ordering)
-> (Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Outcome)
-> (Outcome -> Outcome -> Outcome)
-> Ord Outcome
Outcome -> Outcome -> Bool
Outcome -> Outcome -> Ordering
Outcome -> Outcome -> Outcome
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 :: Outcome -> Outcome -> Ordering
compare :: Outcome -> Outcome -> Ordering
$c< :: Outcome -> Outcome -> Bool
< :: Outcome -> Outcome -> Bool
$c<= :: Outcome -> Outcome -> Bool
<= :: Outcome -> Outcome -> Bool
$c> :: Outcome -> Outcome -> Bool
> :: Outcome -> Outcome -> Bool
$c>= :: Outcome -> Outcome -> Bool
>= :: Outcome -> Outcome -> Bool
$cmax :: Outcome -> Outcome -> Outcome
max :: Outcome -> Outcome -> Outcome
$cmin :: Outcome -> Outcome -> Outcome
min :: Outcome -> Outcome -> Outcome
Ord, Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Outcome -> ShowS
showsPrec :: Int -> Outcome -> ShowS
$cshow :: Outcome -> String
show :: Outcome -> String
$cshowList :: [Outcome] -> ShowS
showList :: [Outcome] -> ShowS
Show, Int -> Outcome
Outcome -> Int
Outcome -> [Outcome]
Outcome -> Outcome
Outcome -> Outcome -> [Outcome]
Outcome -> Outcome -> Outcome -> [Outcome]
(Outcome -> Outcome)
-> (Outcome -> Outcome)
-> (Int -> Outcome)
-> (Outcome -> Int)
-> (Outcome -> [Outcome])
-> (Outcome -> Outcome -> [Outcome])
-> (Outcome -> Outcome -> [Outcome])
-> (Outcome -> Outcome -> Outcome -> [Outcome])
-> Enum Outcome
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Outcome -> Outcome
succ :: Outcome -> Outcome
$cpred :: Outcome -> Outcome
pred :: Outcome -> Outcome
$ctoEnum :: Int -> Outcome
toEnum :: Int -> Outcome
$cfromEnum :: Outcome -> Int
fromEnum :: Outcome -> Int
$cenumFrom :: Outcome -> [Outcome]
enumFrom :: Outcome -> [Outcome]
$cenumFromThen :: Outcome -> Outcome -> [Outcome]
enumFromThen :: Outcome -> Outcome -> [Outcome]
$cenumFromTo :: Outcome -> Outcome -> [Outcome]
enumFromTo :: Outcome -> Outcome -> [Outcome]
$cenumFromThenTo :: Outcome -> Outcome -> Outcome -> [Outcome]
enumFromThenTo :: Outcome -> Outcome -> Outcome -> [Outcome]
Enum, Outcome
Outcome -> Outcome -> Bounded Outcome
forall a. a -> a -> Bounded a
$cminBound :: Outcome
minBound :: Outcome
$cmaxBound :: Outcome
maxBound :: Outcome
Bounded)

data Function = Function
    { Function -> String
fnFile   :: FilePath
    , Function -> Text
fnName   :: Text
    , Function -> [Text]
fnParams :: [Text]
    , Function -> Shape
fnShape  :: Shape
    , Function -> Node (Lexeme Text)
fnDefn   :: C.Node (Lexeme Text)
    }

universe :: C.Node (Lexeme Text) -> [C.Node (Lexeme Text)]
universe :: Node (Lexeme Text) -> [Node (Lexeme Text)]
universe node :: Node (Lexeme Text)
node@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = Node (Lexeme Text)
node Node (Lexeme Text) -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. a -> [a] -> [a]
: (Node (Lexeme Text) -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node (Lexeme Text) -> [Node (Lexeme Text)]
universe ((Node (Lexeme Text)
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> [Node (Lexeme Text)]
forall a b. (a -> b -> b) -> b -> NodeF (Lexeme Text) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] NodeF (Lexeme Text) (Node (Lexeme Text))
n)

lexemeText :: Lexeme Text -> Text
lexemeText :: Lexeme Text -> Text
lexemeText (L AlexPosn
_ LexemeClass
_ Text
t) = Text
t

strip :: C.Node (Lexeme Text) -> C.Node (Lexeme Text)
strip :: Node (Lexeme Text) -> Node (Lexeme Text)
strip = \case
    Fix (ParenExpr Node (Lexeme Text)
e) -> Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
e
    Node (Lexeme Text)
e                 -> Node (Lexeme Text)
e

-- | Get the value of an integer literal, including negative ones.
intLit :: C.Node (Lexeme Text) -> Maybe Integer
intLit :: Node (Lexeme Text) -> Maybe Integer
intLit 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
    LiteralExpr LiteralType
C.Int (L AlexPosn
_ LexemeClass
_ Text
t)                    -> Text -> Maybe Integer
forall {a}. Read a => Text -> Maybe a
readInt Text
t
    UnaryExpr UnaryOp
UopMinus (Fix (LiteralExpr LiteralType
C.Int Lexeme Text
l)) -> Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Integer
forall {a}. Read a => Text -> Maybe a
readInt (Lexeme Text -> Text
lexemeText Lexeme Text
l)
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                                              -> Maybe Integer
forall a. Maybe a
Nothing
  where
    readInt :: Text -> Maybe a
readInt Text
t = case ReadS a
forall a. Read a => ReadS a
reads (Text -> String
Text.unpack Text
t) of
        [(a
n, String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
n
        [(a, String)]
_         -> Maybe a
forall a. Maybe a
Nothing

unFix' :: C.Node (Lexeme Text) -> NodeF (Lexeme Text) (C.Node (Lexeme Text))
unFix' :: Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = NodeF (Lexeme Text) (Node (Lexeme Text))
n

-- | Get the name of a named constant, e.g. @true@, @nullptr@ or @TOX_OK@.
constName :: C.Node (Lexeme Text) -> Maybe Text
constName :: Node (Lexeme Text) -> Maybe Text
constName 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
    LiteralExpr LiteralType
_ (L AlexPosn
_ LexemeClass
_ Text
t) | (Char -> Bool) -> Text -> Bool
Text.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'a'..Char
'z'] Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z'] Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']) Text
t
                            , Bool -> Bool
not (Text -> Bool
Text.null Text
t) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe Text
forall a. Maybe a
Nothing

isNullLit :: C.Node (Lexeme Text) -> Bool
isNullLit :: Node (Lexeme Text) -> Bool
isNullLit 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"]

-- | Find the expression a condition tests for null, mapped through @view@,
-- and the branch on which it is null.
nullTest :: (C.Node (Lexeme Text) -> Maybe a) -> C.Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest :: forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe a
view 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
    UnaryExpr UnaryOp
UopNot Node (Lexeme Text)
x | Just a
v <- Node (Lexeme Text) -> Maybe a
view Node (Lexeme Text)
x -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a
v, EdgeType
TrueBranch)
    -- Both operands of @&&@ hold on its true branch.
    BinaryExpr Node (Lexeme Text)
l BinaryOp
BopAnd Node (Lexeme Text)
r -> case ((Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe a
view Node (Lexeme Text)
l, (Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
forall a.
(Node (Lexeme Text) -> Maybe a)
-> Node (Lexeme Text) -> Maybe (a, EdgeType)
nullTest Node (Lexeme Text) -> Maybe a
view Node (Lexeme Text)
r) of
        (Just t :: (a, EdgeType)
t@(a
_, EdgeType
TrueBranch), Maybe (a, EdgeType)
_) -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a, EdgeType)
t
        (Maybe (a, EdgeType)
_, Just t :: (a, EdgeType)
t@(a
_, EdgeType
TrueBranch)) -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a, EdgeType)
t
        (Maybe (a, EdgeType), Maybe (a, EdgeType))
_                           -> Maybe (a, EdgeType)
forall a. Maybe a
Nothing
    BinaryExpr Node (Lexeme Text)
x BinaryOp
op Node (Lexeme Text)
r | Node (Lexeme Text) -> Bool
isNullLit Node (Lexeme Text)
r, Just a
v <- Node (Lexeme Text) -> Maybe a
view Node (Lexeme Text)
x -> case BinaryOp
op of
        BinaryOp
BopEq -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a
v, EdgeType
TrueBranch)
        BinaryOp
BopNe -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a
v, EdgeType
FalseBranch)
        BinaryOp
_     -> Maybe (a, EdgeType)
forall a. Maybe a
Nothing
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ | Just a
v <- Node (Lexeme Text) -> Maybe a
view Node (Lexeme Text)
cond -> (a, EdgeType) -> Maybe (a, EdgeType)
forall a. a -> Maybe a
Just (a
v, EdgeType
FalseBranch)
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe (a, EdgeType)
forall a. Maybe a
Nothing

isEnumConst :: Text -> Bool
isEnumConst :: Text -> Bool
isEnumConst Text
t = (Char -> Bool) -> Text -> Bool
Text.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z'] Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'0'..Char
'9']) Text
t
    Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.any (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A'..Char
'Z']) Text
t

-- | Whether a branch on an error flag can be taken with the enum constants
-- the flags hold.
flagHolds :: Map String Text -> C.Node (Lexeme Text) -> EdgeType -> Bool
flagHolds :: Map String Text -> Node (Lexeme Text) -> EdgeType -> Bool
flagHolds Map String Text
flags Node (Lexeme Text)
cond EdgeType
e = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
unFix' (Node (Lexeme Text) -> Node (Lexeme Text)
strip Node (Lexeme Text)
cond) of
    BinaryExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) BinaryOp
op Node (Lexeme Text)
r
        | Just Text
c <- Node (Lexeme Text) -> Maybe Text
constName Node (Lexeme Text)
r, Just Text
c' <- String -> Map String Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> String
Text.unpack Text
v) Map String Text
flags, BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
BopEq, BinaryOp
BopNe] ->
            let equal :: Bool
equal = Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
c'
            in case EdgeType
e of
                EdgeType
TrueBranch  -> if BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
BopEq then Bool
equal else Bool -> Bool
not Bool
equal
                EdgeType
FalseBranch -> if BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
BopEq then Bool -> Bool
not Bool
equal else Bool
equal
                EdgeType
_           -> Bool
True
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Bool
True

shapeOf :: C.Node (Lexeme Text) -> C.Node (Lexeme Text) -> Shape
shapeOf :: Node (Lexeme Text) -> Node (Lexeme Text) -> Shape
shapeOf Node (Lexeme Text)
retType Node (Lexeme Text)
body
    | Text
"bool" Text -> Text -> Bool
`Text.isInfixOf` Text
ty = Shape
BoolShape
    | Text
"*" Text -> Text -> Bool
`Text.isInfixOf` Text
ty = Shape
PtrShape
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`Text.isInfixOf` Text
ty) [Text
"int", Text
"Index", Text
"Number"] = Shape
intShape
    | Bool
otherwise = Shape
NoShape
  where
    ty :: Text
ty = Node (Lexeme Text) -> Text
forall a. Pretty a => Node (Lexeme a) -> Text
showNodePlain Node (Lexeme Text)
retType
    returned :: [Node (Lexeme Text)]
returned = [ Node (Lexeme Text)
e | Fix (Return (Just Node (Lexeme Text)
e)) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
body ]
    lits :: [Maybe Integer]
lits = (Node (Lexeme Text) -> Maybe Integer)
-> [Node (Lexeme Text)] -> [Maybe Integer]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Maybe Integer
intLit [Node (Lexeme Text)]
returned
    intShape :: Shape
intShape
        | (Maybe Integer -> Bool) -> [Maybe Integer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0)) [Maybe Integer]
lits Bool -> Bool -> Bool
&& Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0 Maybe Integer -> [Maybe Integer] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Integer]
lits = Shape
ZeroShape
        | (Maybe Integer -> Bool) -> [Maybe Integer] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0)) [Maybe Integer]
lits = Shape
IdShape
        | Bool
otherwise = Shape
NoShape

returnOutcomes :: Shape -> Maybe (C.Node (Lexeme Text)) -> [Outcome]
returnOutcomes :: Shape -> Maybe (Node (Lexeme Text)) -> [Outcome]
returnOutcomes Shape
shape Maybe (Node (Lexeme Text))
ret = case (Shape
shape, Maybe (Node (Lexeme Text))
ret) of
    (Shape
BoolShape, Just 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
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"true"  -> [Outcome
Success]
                        | Node (Lexeme Text) -> Maybe Text
constName Node (Lexeme Text)
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"false" -> [Outcome
Failure]
    (Shape
ZeroShape, Just Node (Lexeme Text)
e) | Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
e Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0               -> [Outcome
Success]
                        | Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
e)     -> [Outcome
Failure]
    (Shape
IdShape, Just Node (Lexeme Text)
e)   | Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
e)     -> [Outcome
Failure]
                        | Bool
otherwise                        -> [Outcome
Success]
    (Shape
PtrShape, Just Node (Lexeme Text)
e)  | Node (Lexeme Text) -> Bool
isNullLit Node (Lexeme Text)
e                      -> [Outcome
Failure]
                        | Bool
otherwise                        -> [Outcome
Success]
    (Shape
NoShape, Maybe (Node (Lexeme Text))
_) -> [Outcome
Success]
    (Shape, Maybe (Node (Lexeme Text)))
_ -> [Outcome
Success, Outcome
Failure]

-- | For a condition on a call's return value, get the call and the outcome it
-- reported on the true branch.
branchOn :: Map Text Shape -> C.Node (Lexeme Text) -> Maybe (Lexeme Text, Outcome)
branchOn :: Map Text Shape
-> Node (Lexeme Text) -> Maybe (Lexeme Text, Outcome)
branchOn Map Text Shape
shapeMap 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
    UnaryExpr UnaryOp
UopNot Node (Lexeme Text)
e -> (Outcome -> Outcome)
-> (Lexeme Text, Outcome) -> (Lexeme Text, Outcome)
forall a b. (a -> b) -> (Lexeme Text, a) -> (Lexeme Text, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Outcome -> Outcome
flipOutcome ((Lexeme Text, Outcome) -> (Lexeme Text, Outcome))
-> Maybe (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text Shape
-> Node (Lexeme Text) -> Maybe (Lexeme Text, Outcome)
branchOn Map Text Shape
shapeMap Node (Lexeme Text)
e
    BinaryExpr Node (Lexeme Text)
l BinaryOp
op Node (Lexeme Text)
r
        | Just (Lexeme Text
f, Shape
s) <- Node (Lexeme Text) -> Maybe (Lexeme Text, Shape)
call Node (Lexeme Text)
l, Just Integer
n <- Node (Lexeme Text) -> Maybe Integer
intLit Node (Lexeme Text)
r -> Lexeme Text
-> Shape -> BinaryOp -> Integer -> Maybe (Lexeme Text, Outcome)
forall {a} {a}.
(Eq a, Num a) =>
a -> Shape -> BinaryOp -> a -> Maybe (a, Outcome)
compareInt Lexeme Text
f Shape
s BinaryOp
op Integer
n
        | Just (Lexeme Text
f, Shape
PtrShape) <- Node (Lexeme Text) -> Maybe (Lexeme Text, Shape)
call Node (Lexeme Text)
l, Node (Lexeme Text) -> Bool
isNullLit Node (Lexeme Text)
r -> case BinaryOp
op of
            BinaryOp
BopEq -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
f, Outcome
Failure)
            BinaryOp
BopNe -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
f, Outcome
Success)
            BinaryOp
_     -> Maybe (Lexeme Text, Outcome)
forall a. Maybe a
Nothing
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ | Just (Lexeme Text
f, Shape
s) <- Node (Lexeme Text) -> Maybe (Lexeme Text, Shape)
call Node (Lexeme Text)
cond -> case Shape
s of
        Shape
BoolShape -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
f, Outcome
Success)
        Shape
PtrShape  -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
f, Outcome
Success)
        Shape
ZeroShape -> (Lexeme Text, Outcome) -> Maybe (Lexeme Text, Outcome)
forall a. a -> Maybe a
Just (Lexeme Text
f, Outcome
Failure)
        Shape
_         -> Maybe (Lexeme Text, Outcome)
forall a. Maybe a
Nothing
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe (Lexeme Text, Outcome)
forall a. Maybe a
Nothing
  where
    call :: Node (Lexeme Text) -> Maybe (Lexeme Text, Shape)
call 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)]
_ | Just Text
name <- Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee, Just Shape
s <- Text -> Map Text Shape -> Maybe Shape
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Shape
shapeMap ->
            (Lexeme Text, Shape) -> Maybe (Lexeme Text, Shape)
forall a. a -> Maybe a
Just (Node (Lexeme Text) -> Lexeme Text
calleeLexeme Node (Lexeme Text)
callee, Shape
s)
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Maybe (Lexeme Text, Shape)
forall a. Maybe a
Nothing
    flipOutcome :: Outcome -> Outcome
flipOutcome Outcome
Success = Outcome
Failure
    flipOutcome Outcome
Failure = Outcome
Success
    compareInt :: a -> Shape -> BinaryOp -> a -> Maybe (a, Outcome)
compareInt a
f Shape
s BinaryOp
op a
n = case (Shape
s, BinaryOp
op, a
n) of
        (Shape
ZeroShape, BinaryOp
BopNe, a
0) -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Failure)
        (Shape
ZeroShape, BinaryOp
BopEq, a
0) -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Success)
        (Shape
BoolShape, BinaryOp
BopNe, a
0) -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Success)
        (Shape
BoolShape, BinaryOp
BopEq, a
0) -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Failure)
        (Shape
_, BinaryOp
BopLt, a
0)         -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Failure)
        (Shape
_, BinaryOp
BopGe, a
0)         -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Success)
        (Shape
_, BinaryOp
BopEq, -1)        -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Failure)
        (Shape
_, BinaryOp
BopNe, -1)        -> (a, Outcome) -> Maybe (a, Outcome)
forall a. a -> Maybe a
Just (a
f, Outcome
Success)
        (Shape, BinaryOp, a)
_                     -> Maybe (a, Outcome)
forall a. Maybe a
Nothing

calleeLexeme :: C.Node (Lexeme Text) -> Lexeme Text
calleeLexeme :: Node (Lexeme Text) -> Lexeme Text
calleeLexeme 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 Lexeme Text
l       -> Lexeme Text
l
    LiteralExpr LiteralType
_ Lexeme Text
l -> Lexeme Text
l
    NodeF (Lexeme Text) (Node (Lexeme Text))
_               -> 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
""

definitions :: [(FilePath, [C.Node (Lexeme Text)])] -> [Function]
definitions :: [(String, [Node (Lexeme Text)])] -> [Function]
definitions [(String, [Node (Lexeme Text)])]
tus = [ Function
f | (String
file, [Node (Lexeme Text)]
nodes) <- [(String, [Node (Lexeme Text)])]
tus, Node (Lexeme Text)
node <- [Node (Lexeme Text)]
nodes, Function
f <- String -> Node (Lexeme Text) -> [Function]
go String
file Node (Lexeme Text)
node ]
  where
    go :: String -> Node (Lexeme Text) -> [Function]
go String
file node :: Node (Lexeme Text)
node@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n) = case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
        FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
ret (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
params)) Node (Lexeme Text)
body ->
            [String -> Text -> [Text] -> Shape -> Node (Lexeme Text) -> Function
Function String
file Text
name ((Node (Lexeme Text) -> Maybe Text)
-> [Node (Lexeme Text)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text) -> Maybe Text
forall {a}. Fix (NodeF (Lexeme a)) -> Maybe a
paramName [Node (Lexeme Text)]
params) (Node (Lexeme Text) -> Node (Lexeme Text) -> Shape
shapeOf Node (Lexeme Text)
ret Node (Lexeme Text)
body) Node (Lexeme Text)
node]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> (Node (Lexeme Text) -> [Function])
-> [Node (Lexeme Text)] -> [Function]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Node (Lexeme Text) -> [Function]
go String
file) ((Node (Lexeme Text)
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> [Node (Lexeme Text)]
forall a b. (a -> b -> b) -> b -> NodeF (Lexeme Text) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] NodeF (Lexeme Text) (Node (Lexeme Text))
n)
    paramName :: Fix (NodeF (Lexeme a)) -> Maybe a
paramName = \case
        Fix (VarDecl Fix (NodeF (Lexeme a))
_ (L AlexPosn
_ LexemeClass
_ a
p) [Fix (NodeF (Lexeme a))]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
p
        Fix (NonNullParam Fix (NodeF (Lexeme a))
p)        -> Fix (NodeF (Lexeme a)) -> Maybe a
paramName Fix (NodeF (Lexeme a))
p
        Fix (NullableParam Fix (NodeF (Lexeme a))
p)       -> Fix (NodeF (Lexeme a)) -> Maybe a
paramName Fix (NodeF (Lexeme a))
p
        Fix (NodeF (Lexeme a))
_                           -> Maybe a
forall a. Maybe a
Nothing

-- | Get the local variables of a function with their initialisers.
localDecls :: C.Node (Lexeme Text) -> [(String, Maybe (C.Node (Lexeme Text)))]
localDecls :: Node (Lexeme Text) -> [(String, Maybe (Node (Lexeme Text)))]
localDecls Node (Lexeme Text)
defn = [ (Text -> String
Text.unpack Text
v, Maybe (Node (Lexeme Text))
ini) | Fix (VarDeclStmt (Fix (VarDecl Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
v) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
ini) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
defn ]

-- | Get the values assigned to each local variable after its declaration.
assignments :: C.Node (Lexeme Text) -> Map String [C.Node (Lexeme Text)]
assignments :: Node (Lexeme Text) -> Map String [Node (Lexeme Text)]
assignments Node (Lexeme Text)
defn = ([Node (Lexeme Text)]
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [(String, [Node (Lexeme Text)])]
-> Map String [Node (Lexeme Text)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
(++)
    [ (Text -> String
Text.unpack Text
v, [Node (Lexeme Text)
r]) | Fix (AssignExpr (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v))) AssignOp
_ Node (Lexeme Text)
r) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
defn ]

rootOf :: AccessPath -> Maybe String
rootOf :: AccessPath -> Maybe String
rootOf = \case
    PathVar String
v     -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
    PathField AccessPath
p String
_ -> AccessPath -> Maybe String
rootOf AccessPath
p
    PathIndex AccessPath
p String
_ -> AccessPath -> Maybe String
rootOf AccessPath
p
    PathDeref AccessPath
p   -> AccessPath -> Maybe String
rootOf AccessPath
p
    AccessPath
_             -> Maybe String
forall a. Maybe a
Nothing

-- | Check if a path goes through a pointer, i.e. names memory that outlives
-- the function.
throughPointer :: AccessPath -> Bool
throughPointer :: AccessPath -> Bool
throughPointer = \case
    PathDeref{}   -> Bool
True
    PathField AccessPath
p String
_ -> AccessPath -> Bool
throughPointer AccessPath
p
    PathIndex AccessPath
p String
_ -> AccessPath -> Bool
throughPointer AccessPath
p
    AccessPath
_             -> Bool
False

render :: AccessPath -> Doc ann
render :: forall ann. AccessPath -> Doc ann
render = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (AccessPath -> String) -> AccessPath -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessPath -> String
go
  where
    go :: AccessPath -> String
go = \case
        PathVar String
v                 -> String
v
        PathField (PathDeref AccessPath
p) String
m -> AccessPath -> String
go AccessPath
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"->" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
m
        PathField AccessPath
p String
m             -> AccessPath -> String
go AccessPath
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
m
        PathIndex AccessPath
p String
i             -> AccessPath -> String
go AccessPath
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
        PathDeref AccessPath
p               -> String
"*" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AccessPath -> String
go AccessPath
p
        AccessPath
p                         -> AccessPath -> String
forall a. Show a => a -> String
show AccessPath
p

nodeExprs :: Node -> [C.Node (Lexeme Text)]
nodeExprs :: Node -> [Node (Lexeme Text)]
nodeExprs (Node Int
_ NodeKind
kind) = case NodeKind
kind of
    BranchNode Node (Lexeme Text)
e -> [Node (Lexeme Text)
e]
    StmtNode (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
s) -> case NodeF (Lexeme Text) (Node (Lexeme Text))
s of
        ExprStmt Node (Lexeme Text)
e             -> [Node (Lexeme Text)
e]
        Return (Just Node (Lexeme Text)
e)        -> [Node (Lexeme Text)
e]
        VarDeclStmt Node (Lexeme Text)
_ (Just Node (Lexeme Text)
e) -> [Node (Lexeme Text)
e]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ | NodeF (Lexeme Text) (Node (Lexeme Text)) -> Bool
forall {lexeme} {a}. NodeF lexeme a -> Bool
isExpr NodeF (Lexeme Text) (Node (Lexeme Text))
s           -> [NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
s]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                      -> []
    NodeKind
_ -> []
  where
    isExpr :: NodeF lexeme a -> Bool
isExpr = \case
        FunctionCall{} -> Bool
True
        AssignExpr{}   -> Bool
True
        UnaryExpr{}    -> Bool
True
        NodeF lexeme a
_              -> Bool
False

-- | Get the functions a function calls directly by name.
callees :: Function -> [Text]
callees :: Function -> [Text]
callees Function
fn = [ Text
name | Fix (FunctionCall Node (Lexeme Text)
callee [Node (Lexeme Text)]
_) <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe (Function -> Node (Lexeme Text)
fnDefn Function
fn), Just Text
name <- [Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
callee] ]

-- | Compute function summaries bottom-up over the strongly connected
-- components of the call graph. @add@ adds a function's summary, and each
-- cycle is iterated until @look@ stops changing, at most @length + 2@ times.
bottomUp :: Eq k => (Function -> [Text]) -> (s -> Function -> s) -> (s -> Function -> k) -> [Function] -> s -> s
bottomUp :: forall k s.
Eq k =>
(Function -> [Text])
-> (s -> Function -> s)
-> (s -> Function -> k)
-> [Function]
-> s
-> s
bottomUp Function -> [Text]
calls s -> Function -> s
add s -> Function -> k
look [Function]
fns s
s0 = (s -> SCC Function -> s) -> s -> [SCC Function] -> s
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' s -> SCC Function -> s
component s
s0 ([(Function, Text, [Text])] -> [SCC Function]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
Graph.stronglyConnComp [(Function, Text, [Text])]
graph)
  where
    graph :: [(Function, Text, [Text])]
graph = [ (Function
f, Function -> Text
fnName Function
f, Function -> [Text]
calls Function
f) | Function
f <- [Function]
fns ]
    component :: s -> SCC Function -> s
component s
s = \case
        Graph.AcyclicSCC Function
f -> s -> Function -> s
add s
s Function
f
        Graph.CyclicSCC [Function]
fs -> s -> [Function] -> Int -> s
forall {t}. (Num t, Eq t) => s -> [Function] -> t -> s
cycleFix s
s [Function]
fs ([Function] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Function]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 :: Int)
    cycleFix :: s -> [Function] -> t -> s
cycleFix s
s [Function]
_ t
0 = s
s
    cycleFix s
s [Function]
fs t
k =
        let s' :: s
s' = (s -> Function -> s) -> s -> [Function] -> s
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' s -> Function -> s
add s
s [Function]
fs
        in if (Function -> k) -> [Function] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (s -> Function -> k
look s
s') [Function]
fs [k] -> [k] -> Bool
forall a. Eq a => a -> a -> Bool
== (Function -> k) -> [Function] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (s -> Function -> k
look s
s) [Function]
fs then s
s' else s -> [Function] -> t -> s
cycleFix s
s' [Function]
fs (t
k t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

-- | Deallocation functions, with the position of the argument they free.
freers :: Map Text Int
freers :: Map Text Int
freers = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
"free", Int
0), (Text
"mem_delete", Int
1)]

-- | Allocation functions returning fresh memory, with the position of their
-- element count or size argument.
allocators :: Map Text Int
allocators :: Map Text Int
allocators = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Text
"malloc", Int
0), (Text
"calloc", Int
0), (Text
"mem_alloc", Int
1), (Text
"mem_balloc", Int
1), (Text
"mem_valloc", Int
1)]

bare :: C.Node (Lexeme Text) -> C.Node (Lexeme Text)
bare :: Node (Lexeme Text) -> Node (Lexeme Text)
bare = \case
    Fix (ParenExpr Node (Lexeme Text)
e)  -> Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e
    Fix (CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
e) -> Node (Lexeme Text) -> Node (Lexeme Text)
bare Node (Lexeme Text)
e
    Node (Lexeme Text)
e                  -> Node (Lexeme Text)
e

-- | Get the access path of an expression naming a variable, field, element
-- or pointee.
accessPath :: C.Node (Lexeme Text) -> Maybe AccessPath
accessPath :: Node (Lexeme Text) -> Maybe AccessPath
accessPath (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    VarExpr (L AlexPosn
_ LexemeClass
_ Text
v)         -> AccessPath -> Maybe AccessPath
forall a. a -> Maybe a
Just (String -> AccessPath
PathVar (Text -> String
Text.unpack Text
v))
    PointerAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
m) -> AccessPath -> String -> AccessPath
PathField (AccessPath -> String -> AccessPath)
-> (AccessPath -> AccessPath) -> AccessPath -> String -> AccessPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessPath -> AccessPath
PathDeref (AccessPath -> String -> AccessPath)
-> Maybe AccessPath -> Maybe (String -> AccessPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e Maybe (String -> AccessPath) -> Maybe String -> Maybe AccessPath
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack Text
m)
    MemberAccess Node (Lexeme Text)
e (L AlexPosn
_ LexemeClass
_ Text
m)  -> AccessPath -> String -> AccessPath
PathField (AccessPath -> String -> AccessPath)
-> Maybe AccessPath -> Maybe (String -> AccessPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e Maybe (String -> AccessPath) -> Maybe String -> Maybe AccessPath
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack Text
m)
    ArrayAccess Node (Lexeme Text)
e Node (Lexeme Text)
i           -> AccessPath -> String -> AccessPath
PathIndex (AccessPath -> String -> AccessPath)
-> Maybe AccessPath -> Maybe (String -> AccessPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e Maybe (String -> AccessPath) -> Maybe String -> Maybe AccessPath
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> String
Text.unpack (Node (Lexeme Text) -> Text
forall a. Pretty a => Node (Lexeme a) -> Text
showNodePlain Node (Lexeme Text)
i))
    UnaryExpr UnaryOp
UopDeref Node (Lexeme Text)
e      -> AccessPath -> AccessPath
PathDeref (AccessPath -> AccessPath) -> Maybe AccessPath -> Maybe AccessPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e
    ParenExpr Node (Lexeme Text)
e               -> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e
    CastExpr Node (Lexeme Text)
_ Node (Lexeme Text)
e              -> Node (Lexeme Text) -> Maybe AccessPath
accessPath Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                         -> Maybe AccessPath
forall a. Maybe a
Nothing

mapRoot :: (String -> String) -> AccessPath -> AccessPath
mapRoot :: ShowS -> AccessPath -> AccessPath
mapRoot ShowS
f = \case
    PathVar String
v     -> String -> AccessPath
PathVar (ShowS
f String
v)
    PathField AccessPath
p String
m -> AccessPath -> String -> AccessPath
PathField (ShowS -> AccessPath -> AccessPath
mapRoot ShowS
f AccessPath
p) String
m
    PathIndex AccessPath
p String
i -> AccessPath -> String -> AccessPath
PathIndex (ShowS -> AccessPath -> AccessPath
mapRoot ShowS
f AccessPath
p) String
i
    PathDeref AccessPath
p   -> AccessPath -> AccessPath
PathDeref (ShowS -> AccessPath -> AccessPath
mapRoot ShowS
f AccessPath
p)
    AccessPath
p             -> AccessPath
p

-- | Get the names used other than as callees, e.g. a function passed or
-- stored as a value.
valuesUsed :: C.Node (Lexeme Text) -> [Text]
valuesUsed :: Node (Lexeme Text) -> [Text]
valuesUsed Node (Lexeme Text)
node =
    [ Text
v
    | Fix NodeF (Lexeme Text) (Node (Lexeme Text))
n <- Node (Lexeme Text) -> [Node (Lexeme Text)]
universe Node (Lexeme Text)
node
    , Text
v <- case NodeF (Lexeme Text) (Node (Lexeme Text))
n of
        FunctionCall Node (Lexeme Text)
_ [Node (Lexeme Text)]
args -> [ Text
v' | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v')) <- [Node (Lexeme Text)]
args ]
        NodeF (Lexeme Text) (Node (Lexeme Text))
_                   -> [ Text
v' | Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
v')) <- (Node (Lexeme Text)
 -> [Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> [Node (Lexeme Text)]
-> NodeF (Lexeme Text) (Node (Lexeme Text))
-> [Node (Lexeme Text)]
forall a b. (a -> b -> b) -> b -> NodeF (Lexeme Text) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] NodeF (Lexeme Text) (Node (Lexeme Text))
n ]
    ]