{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
{- | Type Points From analysis in the style of
- Cork: Dynamic Memory Leak Detectionfor Garbage-Collected Languages
- https://dl.acm.org/doi/10.1145/1190216.1190224
- -}
module GHC.Debug.TypePointsFrom( typePointsFrom
                               , detectLeaks
                               , TypePointsFrom(..)
                               , getNodes
                               , getEdges
                               , edgeSource
                               , edgeTarget
                               , Key
                               , Edge(..)
                               , getKey
                               ) where

import GHC.Debug.Client.Monad
import GHC.Debug.Client
import Control.Monad.State
import GHC.Debug.ParTrace
import GHC.Debug.Types.Ptr
import qualified Data.Map.Monoidal.Strict as Map
import Data.Map (Map)
import qualified Data.Map.Internal as M
import GHC.Debug.Profile
import Control.Monad.Identity
import Control.Concurrent
import Data.List (sortOn)
import Language.Dot
import qualified Data.Set as S


type Key = InfoTablePtr

data Edge = Edge !Key !Key deriving (Edge -> Edge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c== :: Edge -> Edge -> Bool
Eq, Eq Edge
Edge -> Edge -> Bool
Edge -> Edge -> Ordering
Edge -> Edge -> Edge
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
min :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmax :: Edge -> Edge -> Edge
>= :: Edge -> Edge -> Bool
$c>= :: Edge -> Edge -> Bool
> :: Edge -> Edge -> Bool
$c> :: Edge -> Edge -> Bool
<= :: Edge -> Edge -> Bool
$c<= :: Edge -> Edge -> Bool
< :: Edge -> Edge -> Bool
$c< :: Edge -> Edge -> Bool
compare :: Edge -> Edge -> Ordering
$ccompare :: Edge -> Edge -> Ordering
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Edge] -> ShowS
$cshowList :: [Edge] -> ShowS
show :: Edge -> [Char]
$cshow :: Edge -> [Char]
showsPrec :: Int -> Edge -> ShowS
$cshowsPrec :: Int -> Edge -> ShowS
Show)

edgeSource :: Edge -> Key
edgeTarget :: Edge -> Key
edgeSource :: Edge -> Key
edgeSource (Edge Key
k1 Key
_) = Key
k1
edgeTarget :: Edge -> Key
edgeTarget (Edge Key
_ Key
k2) = Key
k2

data TypePointsFrom = TypePointsFrom { TypePointsFrom -> MonoidalMap Key CensusStats
nodes :: !(Map.MonoidalMap Key CensusStats)
                                      , TypePointsFrom -> MonoidalMap Edge CensusStats
edges :: !(Map.MonoidalMap Edge CensusStats)
                                      } deriving (Int -> TypePointsFrom -> ShowS
[TypePointsFrom] -> ShowS
TypePointsFrom -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypePointsFrom] -> ShowS
$cshowList :: [TypePointsFrom] -> ShowS
show :: TypePointsFrom -> [Char]
$cshow :: TypePointsFrom -> [Char]
showsPrec :: Int -> TypePointsFrom -> ShowS
$cshowsPrec :: Int -> TypePointsFrom -> ShowS
Show)

getNodes :: TypePointsFrom -> Map Key CensusStats
getEdges :: TypePointsFrom -> Map Edge CensusStats
getNodes :: TypePointsFrom -> Map Key CensusStats
getNodes = forall k a. MonoidalMap k a -> Map k a
Map.getMonoidalMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
nodes
getEdges :: TypePointsFrom -> Map Edge CensusStats
getEdges = forall k a. MonoidalMap k a -> Map k a
Map.getMonoidalMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Edge CensusStats
edges

instance Monoid TypePointsFrom where
  mempty :: TypePointsFrom
mempty = MonoidalMap Key CensusStats
-> MonoidalMap Edge CensusStats -> TypePointsFrom
TypePointsFrom forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance Semigroup TypePointsFrom where
  (TypePointsFrom MonoidalMap Key CensusStats
a1 MonoidalMap Edge CensusStats
a2) <> :: TypePointsFrom -> TypePointsFrom -> TypePointsFrom
<> (TypePointsFrom MonoidalMap Key CensusStats
b1 MonoidalMap Edge CensusStats
b2) = MonoidalMap Key CensusStats
-> MonoidalMap Edge CensusStats -> TypePointsFrom
TypePointsFrom (MonoidalMap Key CensusStats
a1 forall a. Semigroup a => a -> a -> a
<> MonoidalMap Key CensusStats
b1) (MonoidalMap Edge CensusStats
a2 forall a. Semigroup a => a -> a -> a
<> MonoidalMap Edge CensusStats
b2)

singletonTPF :: Key -> CensusStats -> [(Edge, CensusStats)] -> TypePointsFrom
singletonTPF :: Key -> CensusStats -> [(Edge, CensusStats)] -> TypePointsFrom
singletonTPF Key
k CensusStats
s [(Edge, CensusStats)]
es = MonoidalMap Key CensusStats
-> MonoidalMap Edge CensusStats -> TypePointsFrom
TypePointsFrom (forall k a. k -> a -> MonoidalMap k a
Map.singleton Key
k CensusStats
s)
                                  (forall k a. Ord k => [(k, a)] -> MonoidalMap k a
Map.fromList [(Edge, CensusStats)]
es)

-- | Perform a "type points from" heap census
typePointsFrom :: [ClosurePtr] -> DebugM TypePointsFrom
typePointsFrom :: [ClosurePtr] -> DebugM TypePointsFrom
typePointsFrom [ClosurePtr]
cs = forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO Context TypePointsFrom
funcs (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo Context
Root) [ClosurePtr]
cs)

  where
    nop :: b -> DebugM ()
nop = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
    funcs :: TraceFunctionsIO Context TypePointsFrom
funcs = forall a s.
(GenPapPayload ClosurePtr -> DebugM ())
-> (GenStackFrames ClosurePtr -> DebugM ())
-> (ClosurePtr
    -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-> (ClosurePtr -> a -> DebugM s)
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO a s
TraceFunctionsIO forall {b}. b -> DebugM ()
nop forall {b}. b -> DebugM ()
nop ClosurePtr
-> SizedClosure
-> Context
-> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
clos ClosurePtr -> Context -> DebugM TypePointsFrom
visit forall {b}. b -> DebugM ()
nop

    visit :: ClosurePtr -> Context -> DebugM TypePointsFrom
    visit :: ClosurePtr -> Context -> DebugM TypePointsFrom
visit ClosurePtr
cp Context
ctx = do
      SizedClosure
sc <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
      let k :: Key
k = StgInfoTableWithPtr -> Key
tableId forall a b. (a -> b) -> a -> b
$ forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
          v :: CensusStats
v = Size -> CensusStats
mkCS (forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize SizedClosure
sc)
          parent_edge :: [(Edge, CensusStats)]
parent_edge = case Context
ctx of
                          Context
Root -> []
                          Parent Key
pk -> [(Key -> Key -> Edge
Edge Key
k Key
pk, CensusStats
v)]
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MonoidalMap Key CensusStats
-> MonoidalMap Edge CensusStats -> TypePointsFrom
TypePointsFrom forall k a. MonoidalMap k a
Map.empty (forall k a. Ord k => [(k, a)] -> MonoidalMap k a
Map.fromList [(Edge, CensusStats)]
parent_edge)



    clos :: ClosurePtr -> SizedClosure -> Context
              -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
    clos :: ClosurePtr
-> SizedClosure
-> Context
-> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
clos ClosurePtr
_cp SizedClosure
sc Context
ctx = do
      let k :: Key
k = StgInfoTableWithPtr -> Key
tableId forall a b. (a -> b) -> a -> b
$ forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
      let s :: Size
          s :: Size
s = forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize SizedClosure
sc
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
s

          -- Edges point from the object TO what retains it
          parent_edge :: [(Edge, CensusStats)]
parent_edge = case Context
ctx of
                          Context
Root -> []
                          Parent Key
pk -> [(Key -> Key -> Edge
Edge Key
k Key
pk, CensusStats
v)]

      forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Context
Parent Key
k, Key -> CensusStats -> [(Edge, CensusStats)] -> TypePointsFrom
singletonTPF Key
k CensusStats
v [(Edge, CensusStats)]
parent_edge, forall a. a -> a
id)


data Context = Root | Parent Key


-- | Repeatedly call 'typesPointsFrom' and perform the leak detection
-- analysis.
detectLeaks :: Int -> Debuggee -> IO ()
detectLeaks :: Int -> Debuggee -> IO ()
detectLeaks Int
interval Debuggee
e = Maybe TypePointsFrom -> RankMaps -> Int -> IO ()
loop forall a. Maybe a
Nothing (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty) Int
0
  where
    loop :: Maybe TypePointsFrom -> RankMaps -> Int -> IO ()
    loop :: Maybe TypePointsFrom -> RankMaps -> Int -> IO ()
loop Maybe TypePointsFrom
prev_census RankMaps
rms Int
i = do
      forall a. Show a => a -> IO ()
print Int
i
      Int -> IO ()
threadDelay (Int
interval forall a. Num a => a -> a -> a
* Int
1_000_000)
      Debuggee -> IO ()
pause Debuggee
e
      ([Graph]
gs, TypePointsFrom
r, RankMaps
new_rmaps) <- forall a. Debuggee -> DebugM a -> IO a
runTrace Debuggee
e forall a b. (a -> b) -> a -> b
$ do
        [RawBlock]
_ <- DebugM [RawBlock]
precacheBlocks
        [ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
        forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClosurePtr]
rs)
        TypePointsFrom
res <- [ClosurePtr] -> DebugM TypePointsFrom
typePointsFrom [ClosurePtr]
rs
        let !new_rmaps :: RankMaps
new_rmaps = case Maybe TypePointsFrom
prev_census of
                           Maybe TypePointsFrom
Nothing -> RankMaps
rms
                           Just TypePointsFrom
pcensus -> RankMaps -> TypePointsFrom -> TypePointsFrom -> RankMaps
updateRankMap RankMaps
rms TypePointsFrom
pcensus TypePointsFrom
res
        let cands :: [Key]
cands = RankMap Key -> [Key]
chooseCandidates (forall a b. (a, b) -> a
fst RankMaps
new_rmaps)
        forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
cands)
        [Graph]
gs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RankMap Edge -> Key -> DebugM Graph
findSlice (forall a b. (a, b) -> b
snd RankMaps
new_rmaps)) (forall a. Int -> [a] -> [a]
take Int
10 [Key]
cands)
        return ([Graph]
gs, TypePointsFrom
res, RankMaps
new_rmaps)
      Debuggee -> IO ()
resume Debuggee
e
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Int
n Graph
g -> [Char] -> [Char] -> IO ()
writeFile ([Char]
"slices/"
                                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
i forall a. [a] -> [a] -> [a]
++ [Char]
"-"
                                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
n forall a. [a] -> [a] -> [a]
++ [Char]
".dot")
                                   (Graph -> [Char]
renderDot Graph
g)) [Int
0..] [Graph]
gs
      Maybe TypePointsFrom -> RankMaps -> Int -> IO ()
loop (forall a. a -> Maybe a
Just TypePointsFrom
r) RankMaps
new_rmaps (Int
i forall a. Num a => a -> a -> a
+ Int
1)


-- Analysis code
--
getKey :: InfoTablePtr -> DebugM String
getKey :: Key -> DebugM [Char]
getKey Key
itblp = do
    Maybe SourceInformation
loc <- Key -> DebugM (Maybe SourceInformation)
getSourceInfo Key
itblp
    StgInfoTable
itbl <- Key -> DebugM StgInfoTable
dereferenceInfoTable Key
itblp
    case Maybe SourceInformation
loc of
      Maybe SourceInformation
Nothing -> Key -> StgInfoTable -> DebugM [Char]
getKeyFallback Key
itblp StgInfoTable
itbl
      Just SourceInformation
s -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl) forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> [Char]
renderSourceInfo SourceInformation
s

getKeyFallback :: Key -> StgInfoTable -> DebugM [Char]
getKeyFallback Key
itbp StgInfoTable
itbl = do
    case StgInfoTable -> ClosureType
tipe StgInfoTable
itbl of
      ClosureType
t | ClosureType
CONSTR forall a. Ord a => a -> a -> Bool
<= ClosureType
t Bool -> Bool -> Bool
&& ClosureType
t forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_NOCAF   -> do
        ConstrDesc [Char]
a [Char]
b [Char]
c <- Key -> DebugM ConstrDesc
dereferenceConDesc Key
itbp
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
a forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ [Char]
b forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ [Char]
c
      ClosureType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl)

type Rank = Double
type Decay = Double

data RankInfo = RankInfo !Rank !Int deriving Int -> RankInfo -> ShowS
[RankInfo] -> ShowS
RankInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RankInfo] -> ShowS
$cshowList :: [RankInfo] -> ShowS
show :: RankInfo -> [Char]
$cshow :: RankInfo -> [Char]
showsPrec :: Int -> RankInfo -> ShowS
$cshowsPrec :: Int -> RankInfo -> ShowS
Show

getRank :: RankInfo -> Rank
getRank :: RankInfo -> Rank
getRank (RankInfo Rank
r Int
_) = Rank
r

default_decay :: Decay
default_decay :: Rank
default_decay = Rank
0.15

rank_threshold :: Double
rank_threshold :: Rank
rank_threshold = Rank
100

min_iterations :: Int
min_iterations :: Int
min_iterations = Int
2

applyRankFilter :: RankInfo -> Bool
applyRankFilter :: RankInfo -> Bool
applyRankFilter (RankInfo Rank
r Int
i) = Rank
r forall a. Ord a => a -> a -> Bool
>= Rank
rank_threshold Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
>= Int
min_iterations

-- | Lookup suitable candidates from the RankMap
-- , Chooses values based on 'rank_threshold' and 'min_iterations'
lookupRM :: Key -> RankMap Edge -> [(Edge, RankInfo)]
lookupRM :: Key -> RankMap Edge -> [(Edge, RankInfo)]
lookupRM Key
k RankMap Edge
m = forall k a. Map k a -> [(k, a)]
M.assocs RankMap Edge
filtered_map
  where
    -- TODO, work out how to use these functions O(log n)
    --smaller =  traceShow (M.size m) (M.dropWhileAntitone ((/= k) . edgeSource) $ m)
    --res_map = traceShow (M.size smaller) (M.takeWhileAntitone ((== k) . edgeSource) smaller)
    (RankMap Edge
res_map, RankMap Edge
_) = forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
M.partitionWithKey (\Edge
e RankInfo
_ -> (forall a. Eq a => a -> a -> Bool
== Key
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
edgeSource forall a b. (a -> b) -> a -> b
$ Edge
e) RankMap Edge
m
    filtered_map :: RankMap Edge
filtered_map = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\(RankInfo Rank
r Int
_) -> Rank
r forall a. Ord a => a -> a -> Bool
> Rank
0) RankMap Edge
res_map

mkDotId :: InfoTablePtr -> Id
mkDotId :: Key -> Id
mkDotId (InfoTablePtr Word64
w) = Integer -> Id
IntegerId (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)

findSlice :: RankMap Edge -> Key -> DebugM Graph
findSlice :: RankMap Edge -> Key -> DebugM Graph
findSlice RankMap Edge
rm Key
k = GraphStrictness
-> GraphDirectedness -> Maybe Id -> [Statement] -> Graph
Graph GraphStrictness
StrictGraph GraphDirectedness
DirectedGraph (forall a. a -> Maybe a
Just (Key -> Id
mkDotId Key
k)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Int -> Key -> StateT (Set Key) DebugM [Statement]
go Int
3 Key
k) forall a. Set a
S.empty

  where

    go :: Int -> InfoTablePtr -> StateT (S.Set InfoTablePtr) DebugM [Statement]
    go :: Int -> Key -> StateT (Set Key) DebugM [Statement]
go Int
n Key
cur_k = do
      Set Key
visited_set <- forall s (m :: * -> *). MonadState s m => m s
get
      -- But don't stop going deep until we've seen a decent number of
      -- nodes
      if forall a. Ord a => a -> Set a -> Bool
S.member Key
cur_k Set Key
visited_set Bool -> Bool -> Bool
|| (Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& forall a. Set a -> Int
S.size Set Key
visited_set forall a. Ord a => a -> a -> Bool
>= Int
20)
        then forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
          [Char]
label <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Key -> DebugM [Char]
getKey Key
cur_k
          let next_edges :: [(Edge, RankInfo)]
next_edges = forall a. Int -> [a] -> [a]
take Int
20 (Key -> RankMap Edge -> [(Edge, RankInfo)]
lookupRM Key
cur_k RankMap Edge
rm)
              -- Decoding very wide is bad
              edge_stmts :: [Statement]
edge_stmts = forall a b. (a -> b) -> [a] -> [b]
map (Edge, RankInfo) -> Statement
mkEdge [(Edge, RankInfo)]
next_edges
              node_stmt :: Statement
node_stmt = NodeId -> [Attribute] -> Statement
NodeStatement (Id -> Maybe Port -> NodeId
NodeId (Key -> Id
mkDotId Key
cur_k) forall a. Maybe a
Nothing) [Id -> Id -> Attribute
AttributeSetValue ([Char] -> Id
StringId [Char]
"label") ([Char] -> Id
StringId [Char]
label) ]
              mkEdge :: (Edge, RankInfo) -> Statement
mkEdge (Edge Key
_ Key
e, RankInfo
ri) = [Entity] -> [Attribute] -> Statement
EdgeStatement [EdgeType -> NodeId -> Entity
ENodeId EdgeType
NoEdge (Id -> Maybe Port -> NodeId
NodeId (Key -> Id
mkDotId Key
cur_k) forall a. Maybe a
Nothing), EdgeType -> NodeId -> Entity
ENodeId EdgeType
DirectedEdge (Id -> Maybe Port -> NodeId
NodeId (Key -> Id
mkDotId Key
e) forall a. Maybe a
Nothing)] [Id -> Id -> Attribute
AttributeSetValue ([Char] -> Id
StringId [Char]
"label") ([Char] -> Id
StringId (forall a. Show a => a -> [Char]
show (RankInfo -> Rank
getRank RankInfo
ri))) ]

          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall a. Ord a => a -> Set a -> Set a
S.insert Key
cur_k)
          [Statement]
ss <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Key -> StateT (Set Key) DebugM [Statement]
go (Int
nforall a. Num a => a -> a -> a
-Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
edgeTarget forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Edge, RankInfo)]
next_edges
          return $ Statement
node_stmt forall a. a -> [a] -> [a]
: [Statement]
edge_stmts forall a. [a] -> [a] -> [a]
++ [Statement]
ss

renderSourceInfo :: SourceInformation -> String
renderSourceInfo :: SourceInformation -> [Char]
renderSourceInfo SourceInformation
s = ShowS
escapeQuotes (SourceInformation -> [Char]
infoName SourceInformation
s forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> [Char]
infoType SourceInformation
s forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> [Char]
infoPosition SourceInformation
s)

escapeQuotes :: String -> String
escapeQuotes :: ShowS
escapeQuotes [] = []
escapeQuotes (Char
'"':[Char]
xs) = Char
'\\' forall a. a -> [a] -> [a]
: Char
'"' forall a. a -> [a] -> [a]
: ShowS
escapeQuotes [Char]
xs
escapeQuotes (Char
x:[Char]
xs) = Char
xforall a. a -> [a] -> [a]
:ShowS
escapeQuotes [Char]
xs


chooseCandidates :: RankMap Key -> [Key]
chooseCandidates :: RankMap Key -> [Key]
chooseCandidates = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (RankInfo -> Rank
getRank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter RankInfo -> Bool
applyRankFilter

type RankMap k = M.Map k RankInfo

type RankMaps = (RankMap Key, RankMap Edge)

type RankUpdateMap k = M.Map k RankUpdateInfo

type RankUpdateInfo = Int -> Double -> Double

-- | Update the current rank predictions based on the difference between
-- two censuses.
updateRankMap :: (RankMap Key, RankMap Edge)
              -> TypePointsFrom
              -> TypePointsFrom
              -> (RankMap Key, RankMap Edge)
updateRankMap :: RankMaps -> TypePointsFrom -> TypePointsFrom -> RankMaps
updateRankMap (RankMap Key
rm_n, RankMap Edge
rm_e) TypePointsFrom
t1 TypePointsFrom
t2 = (RankMap Key
ns, RankMap Edge
es)
  where
    !(RankUpdateMap Key
rnodes, RankUpdateMap Edge
redges) = TypePointsFrom
-> TypePointsFrom -> (RankUpdateMap Key, RankUpdateMap Edge)
ratioRank TypePointsFrom
t1 TypePointsFrom
t2
    missingL :: WhenMissing Identity k x y
missingL = forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    missingR :: WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR = forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
M.mapMissing (\k
_ Int -> Rank -> Rank
f -> Rank -> Int -> RankInfo
RankInfo (Int -> Rank -> Rank
f Int
0 Rank
0) Int
1)
    matched :: WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
matched = forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
M.zipWithMatched (\k
_ (RankInfo Rank
r Int
iters) Int -> Rank -> Rank
f -> Rank -> Int -> RankInfo
RankInfo (Int -> Rank -> Rank
f Int
iters Rank
r) (Int
iters forall a. Num a => a -> a -> a
+ Int
1))

    !ns :: RankMap Key
ns = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA forall {k} {x} {y}. WhenMissing Identity k x y
missingL forall {k}. WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR forall {k}.
WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
matched RankMap Key
rm_n RankUpdateMap Key
rnodes
    !es :: RankMap Edge
es = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA forall {k} {x} {y}. WhenMissing Identity k x y
missingL forall {k}. WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR forall {k}.
WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
matched RankMap Edge
rm_e RankUpdateMap Edge
redges


compareSize :: CensusStats -> CensusStats -> Maybe (Int -> Double -> Double)
compareSize :: CensusStats -> CensusStats -> Maybe (Int -> Rank -> Rank)
compareSize (CensusStats -> Size
cssize -> Size Int
s1) (CensusStats -> Size
cssize -> Size Int
s2) =
  if forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2 forall a. Ord a => a -> a -> Bool
> (Rank
1 forall a. Num a => a -> a -> a
- Rank
default_decay) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1
    -- Calculate "Q"
    then if Int
s1 forall a. Ord a => a -> a -> Bool
> Int
s2
          -- Shrinking phase, penalise rank
          then forall a. a -> Maybe a
Just (\Int
phases Rank
rank ->
                      Rank
rank
                        forall a. Num a => a -> a -> a
- ((forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
phases forall a. Num a => a -> a -> a
+ Int
1))
                            forall a. Num a => a -> a -> a
* ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2) forall a. Num a => a -> a -> a
- Rank
1)))
          else forall a. a -> Maybe a
Just (\Int
phases Rank
rank ->
                        Rank
rank forall a. Num a => a -> a -> a
+
                          ((forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
phases forall a. Num a => a -> a -> a
+ Int
1))
                            forall a. Num a => a -> a -> a
* ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1) forall a. Num a => a -> a -> a
- Rank
1)))
    else forall a. Maybe a
Nothing

-- | Compute how to update the ranks based on the difference between two
-- censuses.
ratioRank :: TypePointsFrom -> TypePointsFrom -> (RankUpdateMap Key, RankUpdateMap Edge)
ratioRank :: TypePointsFrom
-> TypePointsFrom -> (RankUpdateMap Key, RankUpdateMap Edge)
ratioRank TypePointsFrom
t1 TypePointsFrom
t2 = (RankUpdateMap Key
candidates, RankUpdateMap Edge
redges)
  where
    ns1 :: Map Key CensusStats
ns1 = TypePointsFrom -> Map Key CensusStats
getNodes TypePointsFrom
t1
    ns2 :: Map Key CensusStats
ns2 = TypePointsFrom -> Map Key CensusStats
getNodes TypePointsFrom
t2

    es1 :: Map Edge CensusStats
es1 = TypePointsFrom -> Map Edge CensusStats
getEdges TypePointsFrom
t1
    es2 :: Map Edge CensusStats
es2 = TypePointsFrom -> Map Edge CensusStats
getEdges TypePointsFrom
t2
    missingL :: WhenMissing Identity k x y
missingL = forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    missingR :: WhenMissing Identity k x y
missingR = forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    matched :: WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched = forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
M.zipWithMaybeMatched (\k
_ CensusStats
cs1 CensusStats
cs2 -> CensusStats -> CensusStats -> Maybe (Int -> Rank -> Rank)
compareSize CensusStats
cs1 CensusStats
cs2)
    !candidates :: RankUpdateMap Key
candidates = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA forall {k} {x} {y}. WhenMissing Identity k x y
missingL forall {k} {x} {y}. WhenMissing Identity k x y
missingR forall {k}.
WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched Map Key CensusStats
ns1 Map Key CensusStats
ns2

    !redges :: RankUpdateMap Edge
redges = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
M.mergeA forall {k} {x} {y}. WhenMissing Identity k x y
missingL forall {k} {x} {y}. WhenMissing Identity k x y
missingR forall {k}.
WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched Map Edge CensusStats
es1 Map Edge CensusStats
es2