module LLVM.VisualizeGraph (
OutputType(..),
visualizeGraph
) where
import GHC.Conc ( getNumCapabilities )
import Control.Arrow
import Control.Concurrent.ParallelIO.Local
import Control.Monad ( when )
import qualified Data.ByteString as BS
import Data.GraphViz
import Data.Maybe ( isNothing )
import System.Directory
import System.FilePath
import System.FilePath.Glob
import Paths_llvm_tools
import LLVM.Analysis
import LLVM.Analysis.Util.Testing ( buildModule )
import LLVM.Parse ( defaultParserOptions, parseLLVMFile )
import LLVM.HtmlWrapper
import LLVM.SvgInspection
data OutputType = CanvasOutput GraphvizCanvas
| FileOutput GraphvizOutput
| HtmlOutput
deriving (Show)
visualizeGraph :: (ToGraphviz a)
=> FilePath
-> Maybe FilePath
-> OutputType
-> [String]
-> (Module -> [(String, a)])
-> IO ()
visualizeGraph inFile outFile fmt optOptions fromModule = do
let p = parseLLVMFile defaultParserOptions
m <- buildModule [] optOptions p inFile
let gs = fromModule m
case fmt of
HtmlOutput -> do
when (isNothing outFile) $ ioError $ userError "Output directory not specified"
let Just outFile' = outFile
gdir = outFile' </> "graphs"
createDirectoryIfMissing True gdir
let jsAndCss = [ "OpenLayers.js"
, "jquery-1.7.1.js"
, "showGraph.js"
, "graph.css"
]
mapM_ (installStaticFile gdir) jsAndCss
installStaticSubdir "img" gdir
caps <- getNumCapabilities
let actions = map (makeFunctionPage toGraphviz gdir) gs
withPool caps $ \capPool -> parallel_ capPool actions
writeHtmlIndex outFile' (map fst gs)
CanvasOutput o -> mapM_ (\(_,g) -> runGraphvizCanvas' (toGraphviz g) o) gs
FileOutput o -> do
when (isNothing outFile) $ ioError $ userError "Output file not specified"
let Just outFile' = outFile
case gs of
[(_, g)] -> runGraphviz (toGraphviz g) o outFile' >> return ()
_ -> do
createDirectoryIfMissing True outFile'
mapM_ (writeDotGraph toGraphviz outFile' o) gs
installStaticFile :: FilePath -> FilePath -> IO ()
installStaticFile dir name = do
file <- getDataFileName ("share" </> name)
copyFile file (dir </> name)
installStaticSubdir :: FilePath -> FilePath -> IO ()
installStaticSubdir sdir destdir = do
dd <- getDataDir
let patt = dd </> "share" </> sdir </> "*"
files <- namesMatching patt
let toDest f = destdir </> sdir </> takeFileName f
let namesAndDests = map (id &&& toDest) files
createDirectoryIfMissing True (destdir </> sdir)
mapM_ (uncurry copyFile) namesAndDests
makeFunctionPage :: (PrintDotRepr dg n)
=> (a -> dg n)
-> FilePath
-> (FilePath, a)
-> IO ()
makeFunctionPage toGraph gdir (fname, g) = do
let svgname = gdir </> gfilename
dg = toGraph g
dims <- graphvizWithHandle (commandFor dg) dg Svg $ \h -> do
svgContent <- BS.hGetContents h
BS.writeFile svgname svgContent
return (getSvgSize svgContent)
let Just (w, h) = dims
writeHtmlWrapper gdir hfilename gfilename fname w h
where
gfilename = fname <.> "svg"
hfilename = fname <.> "html"
writeDotGraph :: (PrintDotRepr dg n)
=> (a -> dg n)
-> FilePath
-> GraphvizOutput
-> (FilePath, a)
-> IO ()
writeDotGraph toGraph dirname o (funcName, g) =
runGraphviz (toGraph g) o filename >> return ()
where
filename = dirname </> funcName <.> toExt o
toExt :: GraphvizOutput -> String
toExt o =
case o of
Canon -> "dot"
XDot -> "dot"
Eps -> "eps"
Fig -> "fig"
Jpeg -> "jpg"
Pdf -> "pdf"
Png -> "png"
Ps -> "ps"
Ps2 -> "ps"
Svg -> "svg"
_ -> error $ "Unsupported format: " ++ show o