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) <- forall a. Debuggee -> DebugM a -> IO a
run Debuggee
e 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

-- | Exports TypePointsFrom graph to a GML file
addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap
addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap
addSourceInfo TypePointsFrom
tpf = do
    -- Generate a map of InfoTablePtr to SourceInformation pairs
    let ptrs :: [Key]
ptrs = forall k a. MonoidalMap k a -> [k]
MMap.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
TPF.nodes forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf
    [Maybe SourceInformation]
infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Key -> DebugM (Maybe SourceInformation)
getSourceInfo [Key]
ptrs

    let kvPairs :: [(TPF.Key, SourceInformation)]
        kvPairs :: [(Key, SourceInformation)]
kvPairs = do
          (Key
k, Just SourceInformation
si) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
ptrs [Maybe SourceInformation]
infos
          forall (m :: * -> *) a. Monad m => a -> m a
return (Key
k, SourceInformation
si)

        infoMap :: SourceInfoMap
        infoMap :: SourceInfoMap
infoMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key, SourceInformation)]
kvPairs

    forall (m :: * -> *) a. Monad m => a -> m 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ((forall k a. MonoidalMap k a -> [k]
MMap.keys 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key' Map Key Int32
ixMap of
      Maybe Int32
Nothing -> 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 = forall k a. MonoidalMap k a -> [(k, a)]
MMap.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Key CensusStats
TPF.nodes forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf
          edgesKvPairs :: [(Edge, CensusStats)]
edgesKvPairs = forall k a. MonoidalMap k a -> [(k, a)]
MMap.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypePointsFrom -> MonoidalMap Edge CensusStats
TPF.edges forall a b. (a -> b) -> a -> b
$ TypePointsFrom
tpf

      -- Beginning of GML file
      Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Writing to file " forall a. Semigroup a => a -> a -> a
<> String
path forall a. Semigroup a => a -> a -> a
<> String
"..."
      IO ()
writeOpenGML

      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ [(Key, CensusStats)]
nodesKvPairs (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> CensusStats -> IO ()
writeNode)
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ [(Edge, CensusStats)]
edgesKvPairs (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Edge -> CensusStats -> IO ()
writeEdge)

      IO ()
writeCloseGML
      Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Finished writing to GML file..."
      -- End of GML file
      where
        write :: String -> IO ()
write = Handle -> String -> IO ()
hPutStr Handle
outHandle

        writeOpenGML :: IO ()
writeOpenGML =
          String -> IO ()
write forall a b. (a -> b) -> a -> b
$ String
"graph[\n"
            forall a. Semigroup a => a -> a -> a
<> String
"comment \"this is a graph in GML format\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"directed 1\n"

        writeCloseGML :: IO ()
writeCloseGML =
          String -> IO ()
write 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 forall a b. (a -> b) -> a -> b
$ String
"node [\n"
            forall a. Semigroup a => a -> a -> a
<> String
"id " forall a. Semigroup a => a -> a -> a
<> Key -> String
showPtr Key
key' forall a. Semigroup a => a -> a -> a
<> String
"\n"
            forall a. Semigroup a => a -> a -> a
<> CensusStats -> String
gmlShowCensus CensusStats
cs
            forall a. Semigroup a => a -> a -> a
<> Key -> String
gmlShowSourceInfo Key
key'
            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 forall a b. (a -> b) -> a -> b
$ String
"edge [\n"
            forall a. Semigroup a => a -> a -> a
<> String
"source " forall a. Semigroup a => a -> a -> a
<> (Key -> String
showPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
TPF.edgeSource) Edge
edge forall a. Semigroup a => a -> a -> a
<> String
"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"target " forall a. Semigroup a => a -> a -> a
<> (Key -> String
showPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Key
TPF.edgeTarget) Edge
edge forall a. Semigroup a => a -> a -> a
<> String
"\n"
            forall a. Semigroup a => a -> a -> a
<> CensusStats -> String
gmlShowCensus CensusStats
cs
            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))) =
          String
"count " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
c forall a. Semigroup a => a -> a -> a
<> String
"\n"
          forall a. Semigroup a => a -> a -> a
<> String
"size " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
s forall a. Semigroup a => a -> a -> a
<> String
"\n"
          forall a. Semigroup a => a -> a -> a
<> String
"max " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
m forall a. Semigroup a => a -> a -> a
<> String
"\n"

        gmlShowSourceInfo :: TPF.Key -> String
        gmlShowSourceInfo :: Key -> String
gmlShowSourceInfo Key
key = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key SourceInfoMap
infoMap of
          Maybe SourceInformation
Nothing -> forall a. Monoid a => a
mempty
          Just SourceInformation
si -> String
"infoName \"" forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoName SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"infoClosureType \"" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceInformation -> ClosureType
infoClosureType) SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"infoType \"" forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoType SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"infoLabel \"" forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoLabel SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"infoModule \"" forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoModule SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"
            forall a. Semigroup a => a -> a -> a
<> String
"infoPosition \"" forall a. Semigroup a => a -> a -> a
<> SourceInformation -> String
infoPosition SourceInformation
si forall a. Semigroup a => a -> a -> a
<> String
"\"\n"

        showPtr :: TPF.Key -> String
        showPtr :: Key -> String
showPtr = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Int32
lookupId