{-# 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
(Edge -> Edge -> Bool) -> (Edge -> Edge -> Bool) -> Eq Edge
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
Eq Edge
-> (Edge -> Edge -> Ordering)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Edge)
-> (Edge -> Edge -> Edge)
-> Ord 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]
(Int -> Edge -> ShowS)
-> (Edge -> [Char]) -> ([Edge] -> ShowS) -> Show Edge
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]
(Int -> TypePointsFrom -> ShowS)
-> (TypePointsFrom -> [Char])
-> ([TypePointsFrom] -> ShowS)
-> Show TypePointsFrom
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 = MonoidalMap Key CensusStats -> Map Key CensusStats
forall k a. MonoidalMap k a -> Map k a
Map.getMonoidalMap (MonoidalMap Key CensusStats -> Map Key CensusStats)
-> (TypePointsFrom -> MonoidalMap Key CensusStats)
-> TypePointsFrom
-> Map Key CensusStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
nodes
getEdges :: TypePointsFrom -> Map Edge CensusStats
getEdges = MonoidalMap Edge CensusStats -> Map Edge CensusStats
forall k a. MonoidalMap k a -> Map k a
Map.getMonoidalMap (MonoidalMap Edge CensusStats -> Map Edge CensusStats)
-> (TypePointsFrom -> MonoidalMap Edge CensusStats)
-> TypePointsFrom
-> Map Edge CensusStats
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 MonoidalMap Key CensusStats
forall a. Monoid a => a
mempty MonoidalMap Edge CensusStats
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 MonoidalMap Key CensusStats
-> MonoidalMap Key CensusStats -> MonoidalMap Key CensusStats
forall a. Semigroup a => a -> a -> a
<> MonoidalMap Key CensusStats
b1) (MonoidalMap Edge CensusStats
a2 MonoidalMap Edge CensusStats
-> MonoidalMap Edge CensusStats -> MonoidalMap Edge CensusStats
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 (Key -> CensusStats -> MonoidalMap Key CensusStats
forall k a. k -> a -> MonoidalMap k a
Map.singleton Key
k CensusStats
s)
                                  ([(Edge, CensusStats)] -> MonoidalMap Edge CensusStats
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 = TraceFunctionsIO Context TypePointsFrom
-> [ClosurePtrWithInfo Context] -> DebugM TypePointsFrom
forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO Context TypePointsFrom
funcs ((ClosurePtr -> ClosurePtrWithInfo Context)
-> [ClosurePtr] -> [ClosurePtrWithInfo Context]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> ClosurePtr -> ClosurePtrWithInfo Context
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo Context
Root) [ClosurePtr]
cs)

  where
    nop :: b -> DebugM ()
nop = DebugM () -> b -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    funcs :: TraceFunctionsIO Context TypePointsFrom
funcs = (GenPapPayload ClosurePtr -> DebugM ())
-> (GenStackFrames ClosurePtr -> DebugM ())
-> (ClosurePtr
    -> SizedClosure
    -> Context
    -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ()))
-> (ClosurePtr -> Context -> DebugM TypePointsFrom)
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO Context TypePointsFrom
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 GenPapPayload ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop GenStackFrames ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop ClosurePtr
-> SizedClosure
-> Context
-> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
clos ClosurePtr -> Context -> DebugM TypePointsFrom
visit ConstrDesc -> DebugM ()
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 (StgInfoTableWithPtr -> Key) -> StgInfoTableWithPtr -> Key
forall a b. (a -> b) -> a -> b
$ DebugClosure PayloadCont Key StackCont ClosurePtr
-> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (SizedClosure -> DebugClosure PayloadCont Key StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
          v :: CensusStats
v = Size -> CensusStats
mkCS (SizedClosure -> Size
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)]
      TypePointsFrom -> DebugM TypePointsFrom
forall (m :: * -> *) a. Monad m => a -> m a
return (TypePointsFrom -> DebugM TypePointsFrom)
-> TypePointsFrom -> DebugM TypePointsFrom
forall a b. (a -> b) -> a -> b
$ MonoidalMap Key CensusStats
-> MonoidalMap Edge CensusStats -> TypePointsFrom
TypePointsFrom MonoidalMap Key CensusStats
forall k a. MonoidalMap k a
Map.empty ([(Edge, CensusStats)] -> MonoidalMap Edge CensusStats
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 (StgInfoTableWithPtr -> Key) -> StgInfoTableWithPtr -> Key
forall a b. (a -> b) -> a -> b
$ DebugClosure PayloadCont Key StackCont ClosurePtr
-> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (SizedClosure -> DebugClosure PayloadCont Key StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
      let s :: Size
          s :: Size
s = SizedClosure -> Size
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)]

      (Context, TypePointsFrom, DebugM () -> DebugM ())
-> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
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, DebugM () -> DebugM ()
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 Maybe TypePointsFrom
forall a. Maybe a
Nothing (Map Key RankInfo
forall k a. Map k a
M.empty, Map Edge RankInfo
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
      Int -> IO ()
forall a. Show a => a -> IO ()
print Int
i
      Int -> IO ()
threadDelay (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000)
      Debuggee -> IO ()
pause Debuggee
e
      ([Graph]
gs, TypePointsFrom
r, RankMaps
new_rmaps) <- Debuggee
-> DebugM ([Graph], TypePointsFrom, RankMaps)
-> IO ([Graph], TypePointsFrom, RankMaps)
forall a. Debuggee -> DebugM a -> IO a
runTrace Debuggee
e (DebugM ([Graph], TypePointsFrom, RankMaps)
 -> IO ([Graph], TypePointsFrom, RankMaps))
-> DebugM ([Graph], TypePointsFrom, RankMaps)
-> IO ([Graph], TypePointsFrom, RankMaps)
forall a b. (a -> b) -> a -> b
$ do
        [RawBlock]
_ <- DebugM [RawBlock]
precacheBlocks
        [ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
        Int -> DebugM ()
forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite ([ClosurePtr] -> Int
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 = Map Key RankInfo -> [Key]
chooseCandidates (RankMaps -> Map Key RankInfo
forall a b. (a, b) -> a
fst RankMaps
new_rmaps)
        Int -> DebugM ()
forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite ([Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
cands)
        [Graph]
gs <- (Key -> DebugM Graph) -> [Key] -> DebugM [Graph]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map Edge RankInfo -> Key -> DebugM Graph
findSlice (RankMaps -> Map Edge RankInfo
forall a b. (a, b) -> b
snd RankMaps
new_rmaps)) (Int -> [Key] -> [Key]
forall a. Int -> [a] -> [a]
take Int
10 [Key]
cands)
        return ([Graph]
gs, TypePointsFrom
res, RankMaps
new_rmaps)
      Debuggee -> IO ()
resume Debuggee
e
      (Int -> Graph -> IO ()) -> [Int] -> [Graph] -> IO ()
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/"
                                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-"
                                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show @Int Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".dot")
                                   (Graph -> [Char]
renderDot Graph
g)) [Int
0..] [Graph]
gs
      Maybe TypePointsFrom -> RankMaps -> Int -> IO ()
loop (TypePointsFrom -> Maybe TypePointsFrom
forall a. a -> Maybe a
Just TypePointsFrom
r) RankMaps
new_rmaps (Int
i Int -> Int -> Int
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 -> [Char] -> DebugM [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> DebugM [Char]) -> [Char] -> DebugM [Char]
forall a b. (a -> b) -> a -> b
$ ClosureType -> [Char]
forall a. Show a => a -> [Char]
show (StgInfoTable -> ClosureType
tipe StgInfoTable
itbl) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> ShowS
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 ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
t Bool -> Bool -> Bool
&& ClosureType
t ClosureType -> ClosureType -> Bool
forall a. Ord a => a -> a -> Bool
<= ClosureType
CONSTR_NOCAF   -> do
        ConstrDesc [Char]
a [Char]
b [Char]
c <- Key -> DebugM ConstrDesc
dereferenceConDesc Key
itbp
        [Char] -> DebugM [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> DebugM [Char]) -> [Char] -> DebugM [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
b [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
c
      ClosureType
_ -> [Char] -> DebugM [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> DebugM [Char]) -> [Char] -> DebugM [Char]
forall a b. (a -> b) -> a -> b
$ ClosureType -> [Char]
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]
(Int -> RankInfo -> ShowS)
-> (RankInfo -> [Char]) -> ([RankInfo] -> ShowS) -> Show RankInfo
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 Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
>= Rank
rank_threshold Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
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 -> Map Edge RankInfo -> [(Edge, RankInfo)]
lookupRM Key
k Map Edge RankInfo
m = Map Edge RankInfo -> [(Edge, RankInfo)]
forall k a. Map k a -> [(k, a)]
M.assocs Map Edge RankInfo
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)
    (Map Edge RankInfo
res_map, Map Edge RankInfo
_) = (Edge -> RankInfo -> Bool)
-> Map Edge RankInfo -> (Map Edge RankInfo, Map Edge RankInfo)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
M.partitionWithKey (\Edge
e RankInfo
_ -> (Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
k) (Key -> Bool) -> (Edge -> Key) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
edgeSource (Edge -> Bool) -> Edge -> Bool
forall a b. (a -> b) -> a -> b
$ Edge
e) Map Edge RankInfo
m
    filtered_map :: Map Edge RankInfo
filtered_map = (RankInfo -> Bool) -> Map Edge RankInfo -> Map Edge RankInfo
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\(RankInfo Rank
r Int
_) -> Rank
r Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
> Rank
0) Map Edge RankInfo
res_map

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

findSlice :: RankMap Edge -> Key -> DebugM Graph
findSlice :: Map Edge RankInfo -> Key -> DebugM Graph
findSlice Map Edge RankInfo
rm Key
k = GraphStrictness
-> GraphDirectedness -> Maybe Id -> [Statement] -> Graph
Graph GraphStrictness
StrictGraph GraphDirectedness
DirectedGraph (Id -> Maybe Id
forall a. a -> Maybe a
Just (Key -> Id
mkDotId Key
k)) ([Statement] -> Graph) -> DebugM [Statement] -> DebugM Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Set Key) DebugM [Statement]
-> Set Key -> DebugM [Statement]
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) Set Key
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 <- StateT (Set Key) DebugM (Set Key)
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 Key -> Set Key -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Key
cur_k Set Key
visited_set Bool -> Bool -> Bool
|| (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& Set Key -> Int
forall a. Set a -> Int
S.size Set Key
visited_set Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
20)
        then [Statement] -> StateT (Set Key) DebugM [Statement]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
          [Char]
label <- DebugM [Char] -> StateT (Set Key) DebugM [Char]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM [Char] -> StateT (Set Key) DebugM [Char])
-> DebugM [Char] -> StateT (Set Key) DebugM [Char]
forall a b. (a -> b) -> a -> b
$ Key -> DebugM [Char]
getKey Key
cur_k
          let next_edges :: [(Edge, RankInfo)]
next_edges = Int -> [(Edge, RankInfo)] -> [(Edge, RankInfo)]
forall a. Int -> [a] -> [a]
take Int
20 (Key -> Map Edge RankInfo -> [(Edge, RankInfo)]
lookupRM Key
cur_k Map Edge RankInfo
rm)
              -- Decoding very wide is bad
              edge_stmts :: [Statement]
edge_stmts = ((Edge, RankInfo) -> Statement)
-> [(Edge, RankInfo)] -> [Statement]
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) Maybe Port
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) Maybe Port
forall a. Maybe a
Nothing), EdgeType -> NodeId -> Entity
ENodeId EdgeType
DirectedEdge (Id -> Maybe Port -> NodeId
NodeId (Key -> Id
mkDotId Key
e) Maybe Port
forall a. Maybe a
Nothing)] [Id -> Id -> Attribute
AttributeSetValue ([Char] -> Id
StringId [Char]
"label") ([Char] -> Id
StringId (Rank -> [Char]
forall a. Show a => a -> [Char]
show (RankInfo -> Rank
getRank RankInfo
ri))) ]

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

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

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


chooseCandidates :: RankMap Key -> [Key]
chooseCandidates :: Map Key RankInfo -> [Key]
chooseCandidates = ((Key, RankInfo) -> Key) -> [(Key, RankInfo)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, RankInfo) -> Key
forall a b. (a, b) -> a
fst ([(Key, RankInfo)] -> [Key])
-> (Map Key RankInfo -> [(Key, RankInfo)])
-> Map Key RankInfo
-> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, RankInfo)] -> [(Key, RankInfo)]
forall a. [a] -> [a]
reverse ([(Key, RankInfo)] -> [(Key, RankInfo)])
-> (Map Key RankInfo -> [(Key, RankInfo)])
-> Map Key RankInfo
-> [(Key, RankInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, RankInfo) -> Rank) -> [(Key, RankInfo)] -> [(Key, RankInfo)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (RankInfo -> Rank
getRank (RankInfo -> Rank)
-> ((Key, RankInfo) -> RankInfo) -> (Key, RankInfo) -> Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, RankInfo) -> RankInfo
forall a b. (a, b) -> b
snd) ([(Key, RankInfo)] -> [(Key, RankInfo)])
-> (Map Key RankInfo -> [(Key, RankInfo)])
-> Map Key RankInfo
-> [(Key, RankInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Key RankInfo -> [(Key, RankInfo)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Key RankInfo -> [(Key, RankInfo)])
-> (Map Key RankInfo -> Map Key RankInfo)
-> Map Key RankInfo
-> [(Key, RankInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RankInfo -> Bool) -> Map Key RankInfo -> Map Key RankInfo
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 (Map Key RankInfo
rm_n, Map Edge RankInfo
rm_e) TypePointsFrom
t1 TypePointsFrom
t2 = (Map Key RankInfo
ns, Map Edge RankInfo
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 = WhenMissing Identity k x y
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    missingR :: WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR = (k -> (Int -> Rank -> Rank) -> RankInfo)
-> WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
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 = (k -> RankInfo -> (Int -> Rank -> Rank) -> RankInfo)
-> WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

    !ns :: Map Key RankInfo
ns = Identity (Map Key RankInfo) -> Map Key RankInfo
forall a. Identity a -> a
runIdentity (Identity (Map Key RankInfo) -> Map Key RankInfo)
-> Identity (Map Key RankInfo) -> Map Key RankInfo
forall a b. (a -> b) -> a -> b
$ WhenMissing Identity Key RankInfo RankInfo
-> WhenMissing Identity Key (Int -> Rank -> Rank) RankInfo
-> WhenMatched Identity Key RankInfo (Int -> Rank -> Rank) RankInfo
-> Map Key RankInfo
-> RankUpdateMap Key
-> Identity (Map Key RankInfo)
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 WhenMissing Identity Key RankInfo RankInfo
forall {k} {x} {y}. WhenMissing Identity k x y
missingL WhenMissing Identity Key (Int -> Rank -> Rank) RankInfo
forall {k}. WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR WhenMatched Identity Key RankInfo (Int -> Rank -> Rank) RankInfo
forall {k}.
WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
matched Map Key RankInfo
rm_n RankUpdateMap Key
rnodes
    !es :: Map Edge RankInfo
es = Identity (Map Edge RankInfo) -> Map Edge RankInfo
forall a. Identity a -> a
runIdentity (Identity (Map Edge RankInfo) -> Map Edge RankInfo)
-> Identity (Map Edge RankInfo) -> Map Edge RankInfo
forall a b. (a -> b) -> a -> b
$ WhenMissing Identity Edge RankInfo RankInfo
-> WhenMissing Identity Edge (Int -> Rank -> Rank) RankInfo
-> WhenMatched
     Identity Edge RankInfo (Int -> Rank -> Rank) RankInfo
-> Map Edge RankInfo
-> RankUpdateMap Edge
-> Identity (Map Edge RankInfo)
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 WhenMissing Identity Edge RankInfo RankInfo
forall {k} {x} {y}. WhenMissing Identity k x y
missingL WhenMissing Identity Edge (Int -> Rank -> Rank) RankInfo
forall {k}. WhenMissing Identity k (Int -> Rank -> Rank) RankInfo
missingR WhenMatched Identity Edge RankInfo (Int -> Rank -> Rank) RankInfo
forall {k}.
WhenMatched Identity k RankInfo (Int -> Rank -> Rank) RankInfo
matched Map Edge RankInfo
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 Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2 Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
> (Rank
1 Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
- Rank
default_decay) Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
* Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1
    -- Calculate "Q"
    then if Int
s1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s2
          -- Shrinking phase, penalise rank
          then (Int -> Rank -> Rank) -> Maybe (Int -> Rank -> Rank)
forall a. a -> Maybe a
Just (\Int
phases Rank
rank ->
                      Rank
rank
                        Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
- ((Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
phases Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                            Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
* ((Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1 Rank -> Rank -> Rank
forall a. Fractional a => a -> a -> a
/ Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2) Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
- Rank
1)))
          else (Int -> Rank -> Rank) -> Maybe (Int -> Rank -> Rank)
forall a. a -> Maybe a
Just (\Int
phases Rank
rank ->
                        Rank
rank Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
+
                          ((Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
phases Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                            Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
* ((Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s2 Rank -> Rank -> Rank
forall a. Fractional a => a -> a -> a
/ Int -> Rank
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s1) Rank -> Rank -> Rank
forall a. Num a => a -> a -> a
- Rank
1)))
    else Maybe (Int -> Rank -> Rank)
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 = WhenMissing Identity k x y
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    missingR :: WhenMissing Identity k x y
missingR = WhenMissing Identity k x y
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
M.dropMissing
    matched :: WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched = (k -> CensusStats -> CensusStats -> Maybe (Int -> Rank -> Rank))
-> WhenMatched
     Identity k CensusStats CensusStats (Int -> Rank -> Rank)
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 = Identity (RankUpdateMap Key) -> RankUpdateMap Key
forall a. Identity a -> a
runIdentity (Identity (RankUpdateMap Key) -> RankUpdateMap Key)
-> Identity (RankUpdateMap Key) -> RankUpdateMap Key
forall a b. (a -> b) -> a -> b
$ WhenMissing Identity Key CensusStats (Int -> Rank -> Rank)
-> WhenMissing Identity Key CensusStats (Int -> Rank -> Rank)
-> WhenMatched
     Identity Key CensusStats CensusStats (Int -> Rank -> Rank)
-> Map Key CensusStats
-> Map Key CensusStats
-> Identity (RankUpdateMap Key)
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 WhenMissing Identity Key CensusStats (Int -> Rank -> Rank)
forall {k} {x} {y}. WhenMissing Identity k x y
missingL WhenMissing Identity Key CensusStats (Int -> Rank -> Rank)
forall {k} {x} {y}. WhenMissing Identity k x y
missingR WhenMatched
  Identity Key CensusStats CensusStats (Int -> Rank -> Rank)
forall {k}.
WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched Map Key CensusStats
ns1 Map Key CensusStats
ns2

    !redges :: RankUpdateMap Edge
redges = Identity (RankUpdateMap Edge) -> RankUpdateMap Edge
forall a. Identity a -> a
runIdentity (Identity (RankUpdateMap Edge) -> RankUpdateMap Edge)
-> Identity (RankUpdateMap Edge) -> RankUpdateMap Edge
forall a b. (a -> b) -> a -> b
$ WhenMissing Identity Edge CensusStats (Int -> Rank -> Rank)
-> WhenMissing Identity Edge CensusStats (Int -> Rank -> Rank)
-> WhenMatched
     Identity Edge CensusStats CensusStats (Int -> Rank -> Rank)
-> Map Edge CensusStats
-> Map Edge CensusStats
-> Identity (RankUpdateMap Edge)
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 WhenMissing Identity Edge CensusStats (Int -> Rank -> Rank)
forall {k} {x} {y}. WhenMissing Identity k x y
missingL WhenMissing Identity Edge CensusStats (Int -> Rank -> Rank)
forall {k} {x} {y}. WhenMissing Identity k x y
missingR WhenMatched
  Identity Edge CensusStats CensusStats (Int -> Rank -> Rank)
forall {k}.
WhenMatched
  Identity k CensusStats CensusStats (Int -> Rank -> Rank)
matched Map Edge CensusStats
es1 Map Edge CensusStats
es2