module GHC.Debug.GML (writeTpfToGML, addSourceInfo, typePointsFromToGML) where
import GHC.Debug.TypePointsFrom as TPF
import GHC.Debug.Types (SourceInformation(..))
import GHC.Debug.Types.Closures (Size(..))
import GHC.Debug.Profile.Types (CensusStats(..), Count(..))
import GHC.Debug.Client.Monad
import GHC.Debug.Client.Query (getSourceInfo, gcRoots)
import Data.Map as Map
import Data.Int (Int32)
import Data.Semigroup
import qualified Data.Map.Monoidal.Strict as MMap
import qualified Data.Foldable as F
import System.IO
type SourceInfoMap = Map.Map TPF.Key SourceInformation
typePointsFromToGML :: FilePath -> Debuggee -> IO ()
typePointsFromToGML :: String -> Debuggee -> IO ()
typePointsFromToGML String
path Debuggee
e = do
(TypePointsFrom
tpf, SourceInfoMap
infoMap) <- Debuggee
-> DebugM (TypePointsFrom, SourceInfoMap)
-> IO (TypePointsFrom, SourceInfoMap)
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e (DebugM (TypePointsFrom, SourceInfoMap)
-> IO (TypePointsFrom, SourceInfoMap))
-> DebugM (TypePointsFrom, SourceInfoMap)
-> IO (TypePointsFrom, SourceInfoMap)
forall a b. (a -> b) -> a -> b
$ do
[ClosurePtr]
roots <- DebugM [ClosurePtr]
gcRoots
TypePointsFrom
tpf <- [ClosurePtr] -> DebugM TypePointsFrom
TPF.typePointsFrom [ClosurePtr]
roots
SourceInfoMap
si <- TypePointsFrom -> DebugM SourceInfoMap
addSourceInfo TypePointsFrom
tpf
return (TypePointsFrom
tpf, SourceInfoMap
si)
String -> TypePointsFrom -> SourceInfoMap -> IO ()
writeTpfToGML String
path TypePointsFrom
tpf SourceInfoMap
infoMap
addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap
addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap
addSourceInfo TypePointsFrom
tpf = do
let ptrs :: [Key]
ptrs = MonoidalMap Key CensusStats -> [Key]
forall k a. MonoidalMap k a -> [k]
MMap.keys (MonoidalMap Key CensusStats -> [Key])
-> (TypePointsFrom -> MonoidalMap Key CensusStats)
-> TypePointsFrom
-> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
TPF.nodes (TypePointsFrom -> [Key]) -> TypePointsFrom -> [Key]
forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf
[Maybe SourceInformation]
infos <- (Key -> DebugM (Maybe SourceInformation))
-> [Key] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Key -> DebugM (Maybe SourceInformation)
getSourceInfo [Key]
ptrs
let kvPairs :: [(TPF.Key, SourceInformation)]
kvPairs :: [(Key, SourceInformation)]
kvPairs = do
(Key
k, Just SourceInformation
si) <- [Key]
-> [Maybe SourceInformation] -> [(Key, Maybe SourceInformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
ptrs [Maybe SourceInformation]
infos
(Key, SourceInformation) -> [(Key, SourceInformation)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
k, SourceInformation
si)
infoMap :: SourceInfoMap
infoMap :: SourceInfoMap
infoMap = [(Key, SourceInformation)] -> SourceInfoMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key, SourceInformation)]
kvPairs
SourceInfoMap -> DebugM SourceInfoMap
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (SourceInfoMap
infoMap)
writeTpfToGML :: FilePath -> TPF.TypePointsFrom -> SourceInfoMap -> IO ()
writeTpfToGML :: String -> TypePointsFrom -> SourceInfoMap -> IO ()
writeTpfToGML String
path TypePointsFrom
tpf SourceInfoMap
infoMap = do
Handle
outHandle <- String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode
Handle -> IO ()
writeGML Handle
outHandle
Handle -> IO ()
hClose Handle
outHandle
where
ixMap :: Map.Map TPF.Key Int32
ixMap :: Map Key Int32
ixMap = [(Key, Int32)] -> Map Key Int32
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key, Int32)] -> Map Key Int32)
-> [(Key, Int32)] -> Map Key Int32
forall a b. (a -> b) -> a -> b
$ [Key] -> [Int32] -> [(Key, Int32)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((MonoidalMap Key CensusStats -> [Key]
forall k a. MonoidalMap k a -> [k]
MMap.keys (MonoidalMap Key CensusStats -> [Key])
-> (TypePointsFrom -> MonoidalMap Key CensusStats)
-> TypePointsFrom
-> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
nodes) TypePointsFrom
tpf) [Int32
1..]
lookupId :: TPF.Key -> Int32
lookupId :: Key -> Int32
lookupId Key
key' = case Key -> Map Key Int32 -> Maybe Int32
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key' Map Key Int32
ixMap of
Maybe Int32
Nothing -> String -> Int32
forall a. HasCallStack => String -> a
error String
"This shouldn't happen, see function ixMap"
Just Int32
i -> Int32
i
writeGML :: Handle -> IO ()
writeGML :: Handle -> IO ()
writeGML Handle
outHandle = do
let nodesKvPairs :: [(Key, CensusStats)]
nodesKvPairs = MonoidalMap Key CensusStats -> [(Key, CensusStats)]
forall k a. MonoidalMap k a -> [(k, a)]
MMap.assocs (MonoidalMap Key CensusStats -> [(Key, CensusStats)])
-> (TypePointsFrom -> MonoidalMap Key CensusStats)
-> TypePointsFrom
-> [(Key, CensusStats)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
TPF.nodes (TypePointsFrom -> [(Key, CensusStats)])
-> TypePointsFrom -> [(Key, CensusStats)]
forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf
edgesKvPairs :: [(Edge, CensusStats)]
edgesKvPairs = MonoidalMap Edge CensusStats -> [(Edge, CensusStats)]
forall k a. MonoidalMap k a -> [(k, a)]
MMap.assocs (MonoidalMap Edge CensusStats -> [(Edge, CensusStats)])
-> (TypePointsFrom -> MonoidalMap Edge CensusStats)
-> TypePointsFrom
-> [(Edge, CensusStats)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Edge CensusStats
TPF.edges (TypePointsFrom -> [(Edge, CensusStats)])
-> TypePointsFrom -> [(Edge, CensusStats)]
forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Writing to file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"..."
IO ()
writeOpenGML
[(Key, CensusStats)] -> ((Key, CensusStats) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ [(Key, CensusStats)]
nodesKvPairs ((Key -> CensusStats -> IO ()) -> (Key, CensusStats) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> CensusStats -> IO ()
writeNode)
[(Edge, CensusStats)] -> ((Edge, CensusStats) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ [(Edge, CensusStats)]
edgesKvPairs ((Edge -> CensusStats -> IO ()) -> (Edge, CensusStats) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Edge -> CensusStats -> IO ()
writeEdge)
IO ()
writeCloseGML
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Finished writing to GML file..."
where
write :: String -> IO ()
write = Handle -> String -> IO ()
hPutStr Handle
outHandle
writeOpenGML :: IO ()
writeOpenGML =
String -> IO ()
write (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"graph[\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"comment \"this is a graph in GML format\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"directed 1\n"
writeCloseGML :: IO ()
writeCloseGML =
String -> IO ()
write (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"]\n"
writeNode :: TPF.Key -> CensusStats -> IO ()
writeNode :: Key -> CensusStats -> IO ()
writeNode Key
key' CensusStats
cs =
String -> IO ()
write (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"node [\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"id " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
showPtr Key
key' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CensusStats -> String
gmlShowCensus CensusStats
cs
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
gmlShowSourceInfo Key
key'
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]\n"
writeEdge :: TPF.Edge -> CensusStats -> IO ()
writeEdge :: Edge -> CensusStats -> IO ()
writeEdge Edge
edge CensusStats
cs =
String -> IO ()
write (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"edge [\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"source " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Key -> String
showPtr (Key -> String) -> (Edge -> Key) -> Edge -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
TPF.edgeSource) Edge
edge String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"target " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Key -> String
showPtr (Key -> String) -> (Edge -> Key) -> Edge -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
TPF.edgeTarget) Edge
edge String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CensusStats -> String
gmlShowCensus CensusStats
cs
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]\n"
gmlShowCensus :: CensusStats -> String
gmlShowCensus :: CensusStats -> String
gmlShowCensus (CS (Count Int
c) (Size Int
s) (Max (Size Int
m)) Sample
_) =
String
"count " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"size " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"max " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
gmlShowSourceInfo :: TPF.Key -> String
gmlShowSourceInfo :: Key -> String
gmlShowSourceInfo Key
key = case Key -> SourceInfoMap -> Maybe SourceInformation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key SourceInfoMap
infoMap of
Maybe SourceInformation
Nothing -> String
forall a. Monoid a => a
mempty
Just SourceInformation
si -> String
"infoName \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoName SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"infoClosureType \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ClosureType -> String
forall a. Show a => a -> String
show (ClosureType -> String)
-> (SourceInformation -> ClosureType)
-> SourceInformation
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceInformation -> ClosureType
infoClosureType) SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"infoType \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoType SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"infoLabel \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoLabel SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"infoModule \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoModule SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"infoPosition \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoPosition SourceInformation
si String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
showPtr :: TPF.Key -> String
showPtr :: Key -> String
showPtr = Int32 -> String
forall a. Show a => a -> String
show (Int32 -> String) -> (Key -> Int32) -> Key -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Int32
lookupId