Support for exporting TPF graphs to GML

client/src/GHC/Debug/GML.hs

+module GHC.Debug.GML (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.Types.Ptr (ClosurePtr)
+import GHC.Debug.Client.Monad
+import GHC.Debug.Client.Query (getSourceInfo)
+
+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
+
+-- | Exports TypePointsFrom graph to a GML file
+typePointsFromToGML :: FilePath -> Debuggee -> [ClosurePtr] -> IO ()
+typePointsFromToGML path e cs = do
+  (tpf, infoMap) <- runTrace e $ do
+    tpf <- TPF.typePointsFrom cs
+
+    -- Generate a map of InfoTablePtr to SourceInformation pairs
+    let ptrs = MMap.keys . TPF.nodes $ tpf
+    infos <- mapM getSourceInfo ptrs
+
+    let kvPairs :: [(TPF.Key, SourceInformation)]
+        kvPairs = do
+          (k, Just si) <- zip ptrs infos
+          return (k, si)
+
+        infoMap :: SourceInfoMap
+        infoMap = Map.fromList kvPairs
+
+    return (tpf, infoMap)
+
+  writeTpfToGML path tpf infoMap
+
+writeTpfToGML :: FilePath -> TPF.TypePointsFrom -> SourceInfoMap -> IO ()
+writeTpfToGML path tpf infoMap = do
+  outHandle <- openFile path WriteMode
+  writeGML outHandle
+  hClose outHandle
+  where
+    ixMap :: Map.Map TPF.Key Int32
+    ixMap = Map.fromList $ zip ((MMap.keys . nodes) tpf) [1..]
+
+    lookupId :: TPF.Key -> Int32
+    lookupId key' = case Map.lookup key' ixMap of
+      Nothing -> error "This shouldn't happen, see function ixMap"
+      Just i -> i
+
+    writeGML :: Handle -> IO ()
+    writeGML outHandle = do
+      let nodesKvPairs = MMap.assocs . TPF.nodes $ tpf
+          edgesKvPairs = MMap.assocs . TPF.edges $ tpf
+
+      -- Beginning of GML file
+      hPutStrLn stderr $ "Writing to file " <> path <> "..."
+      writeOpenGML
+
+      F.forM_ nodesKvPairs (uncurry writeNode)
+      F.forM_ edgesKvPairs (uncurry writeEdge)
+
+      writeCloseGML
+      hPutStrLn stderr $ "Finished writing to GML file..."
+      -- End of GML file
+      where
+        write = hPutStr outHandle
+
+        writeOpenGML =
+          write $ "graph[\n"
+            <> "comment \"this is a graph in GML format\"\n"
+            <> "directed 1\n"
+
+        writeCloseGML =
+          write $ "]\n"
+
+        writeNode :: TPF.Key -> CensusStats -> IO ()
+        writeNode key' cs =
+          write $ "node [\n"
+            <> "id " <> showPtr key' <> "\n"
+            <> gmlShowCensus cs
+            <> gmlShowSourceInfo key'
+            <> "]\n"
+
+        writeEdge :: TPF.Edge -> CensusStats -> IO ()
+        writeEdge edge cs =
+          write $ "edge [\n"
+            <> "source " <> (showPtr . TPF.edgeSource) edge <> "\n"
+            <> "target " <> (showPtr . TPF.edgeTarget) edge <> "\n"
+            <> gmlShowCensus cs
+            <> "]\n"
+
+        gmlShowCensus :: CensusStats -> String
+        gmlShowCensus (CS (Count c) (Size s) (Max (Size m))) =
+          "count " <> show c <> "\n"
+          <> "size " <> show s <> "\n"
+          <> "max " <> show m <> "\n"
+
+        gmlShowSourceInfo :: TPF.Key -> String
+        gmlShowSourceInfo key = case Map.lookup key infoMap of
+          Nothing -> mempty
+          Just si -> "infoName \"" <> infoName si <> "\"\n"
+            <> "infoClosureType \"" <> (show . infoClosureType) si <> "\"\n"
+            <> "infoType \"" <> infoType si <> "\"\n"
+            <> "infoLabel \"" <> infoLabel si <> "\"\n"
+            <> "infoModule \"" <> infoModule si <> "\"\n"
+            <> "infoPosition \"" <> infoPosition si <> "\"\n"
+
+        showPtr :: TPF.Key -> String
+        showPtr = show . lookupId