Dot.hs

{-
Module      :  $Header$
Description :  Internal control flow graph printing.
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable

-}

module Main.Dot where

import Control.Exception ( catch )
import Control.Monad
import Control.Monad.Trans (liftIO)

import System.Exit
import System.Directory ( doesFileExist, removeFile, findExecutable )
import System.FilePath (dropExtension, addExtension)
import System.Process
import System.IO

import Language.CAO.Analysis.CFG

import Language.CAO.Common.Monad 

import Main.Flags

--------------------------------------------------------------------------------
-- Printing Control Flow Graph

generateCFG :: Options -> [CaoCFG] -> String -> CaoResult ()
generateCFG opts cfg outExt =
    liftIO $ runDotT outExt noExt $ showCFG cfg
    where 
    noExt   = dropExtension $ input opts

runDotT :: String -> String -> String -> IO ()
runDotT outExt outF arg = do
    -- Find dot executable
    mdot <- findExecutable "dot"
    doRunDotT mdot outExt outF arg

doRunDotT :: Maybe FilePath -> String -> FilePath -> String -> IO ()
doRunDotT Nothing _ outF arg = do
    hPutStrLn stderr $ "Graphviz is required by --dgen-cfg\
          \ and --dgen-ssa options."
    hPutStrLn stderr $ "Generating dot file: `" ++ outF ++ "dot'."
    writeFile (addExtension outF "dot") arg
doRunDotT (Just dot) outExt outF arg = do
    -- Open output file
    file <- openFile dotOutputF WriteMode
    hSetBinaryMode file True
    -- Create dot process
    (Just inp, _, _, h)    <- createProcess $ dotProcess file
    -- Feed in input
    hPutStr inp arg
    hFlush  inp
    hClose  inp
    -- Finish
    cd <- waitForProcess h
    cF cd
    `catch` catchF
  
    where 
    dotProcess out
          = (proc dot ["-T" ++ outExt]) { std_in    = CreatePipe
                                        , std_out   = UseHandle out
                                        }
    dotOutputF = addExtension outF outExt

    catchF :: IOError -> IO ()
    catchF _ = cF $ ExitFailure (-1)

    cF :: ExitCode -> IO ()
    cF ExitSuccess     = return ()
    cF (ExitFailure _) = do
        hPutStrLn stderr "`dot' failure!"
        hPutStrLn stderr $ "Generating dot file: `" ++ outF ++ "dot'."
        b <- doesFileExist dotOutputF
        when b $ removeFile dotOutputF
        writeFile (addExtension outF "dot") arg