graph-trace-viz-0.1.1.0: app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import           Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import           Data.FileEmbed (embedFile)
import           Data.Foldable (for_)
import qualified Data.List as List
import           Data.Maybe (isJust)
import qualified System.Directory as Dir
import           System.Environment
import           System.Exit (die)
import           System.IO
import qualified System.Process as Proc

import qualified Graph.Trace.Dot as Dot

main :: IO ()
main = do
  args <- getArgs

  let isFlag arg = "--" `List.isPrefixOf` arg
      (flags, fileArgs) = span isFlag args
      nexusFlag = "--nexus" `List.elem` flags
      helpCommand = "--help" `List.elem` flags

  if helpCommand
  then putStrLn helpText
  else do
    traceFiles <- case fileArgs of
      [] -> do
        contents <- Dir.listDirectory =<< Dir.getCurrentDirectory
        let isTraceFile = (".trace" `List.isSuffixOf`)
        pure $ filter isTraceFile contents
      xs -> pure xs

    for_ traceFiles $ \traceFile -> do
      logContents
        <- either (\err -> fail $ "Failed parsing trace file: " <> err) id
         . Dot.parseLogEntries
       <$> BSL.readFile traceFile

      let tree = Dot.buildTree logContents
          dotFileContent
            | nexusFlag = Dot.graphToDot (Dot.buildNexus tree)
            | otherwise = Dot.graphToDot tree
          fileName = (<> ".html")
                   $ if ".trace" `List.isSuffixOf` traceFile
                        then reverse . drop 6 $ reverse traceFile
                        else traceFile

          htmlHeader = $(embedFile "extras/header.html")
          htmlFooter = $(embedFile "extras/footer.html")

      dotExists <- isJust <$> Dir.findExecutable "dot"
      unless dotExists $ die "Error! Graphviz is not installed or not accessible"

      withFile fileName WriteMode $ \h -> do
        hSetBinaryMode h True
        hSetBuffering h (BlockBuffering Nothing)
        BS.hPut h htmlHeader
        writeSvg h dotFileContent
        BS.hPut h htmlFooter

-- | Invoke @dot@ to produce an svg document and write to the file handle
writeSvg :: Handle -> BSB.Builder -> IO ()
writeSvg htmlFile dotContent =
  Proc.withCreateProcess (Proc.proc "dot" ["-Tsvg"])
      { Proc.std_in = Proc.CreatePipe
      , Proc.std_out = Proc.CreatePipe
      } go
  where
    go (Just stdIn) (Just stdOut) _ _ = do
      hSetBinaryMode stdIn True
      hSetBuffering stdIn (BlockBuffering Nothing)
      hSetBinaryMode stdOut True
      hSetBuffering stdOut (BlockBuffering Nothing)
      _ <- BSB.hPutBuilder stdIn dotContent
      hClose stdIn
      svg <- BSL.hGetContents stdOut
      BSL.hPut htmlFile svg
      hClose stdOut
    go _ _ _ _ = pure ()

helpText :: String
helpText = unlines
  [ "Command line utility for rendering trace files generated by the \
    \graph-trace plugin into an interactive HTML document."
  , ""
  , "Flags:"
  , " --nexus     Causes two or more identical nodes to be merged into one"
  ]