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

-- | 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 = 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)
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 (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 (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 = [(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

      -- Beginning of GML file
      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..."
      -- End of 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))) =
          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