{-# LANGUAGE MultiParamTypeClasses #-}
module Data.GraphViz.Commands.IO
(
toUTF8
, writeDotFile
, readDotFile
, hPutDot
, hPutCompactDot
, hGetDot
, hGetStrict
, putDot
, readDot
, runCommand
) where
import Data.GraphViz.Exception
import Data.GraphViz.Printing (runDotCode, toDot)
import Data.GraphViz.Types (ParseDotRepr, PrintDotRepr, parseDotGraph,
printDotGraph)
import Text.PrettyPrint.Leijen.Text (displayT, renderOneLine)
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar,
takeMVar)
import Control.Exception (IOException, evaluate, finally)
import Control.Monad (liftM)
import qualified Data.ByteString as SB
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import Data.Text.Encoding.Error (UnicodeException)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Encoding as T
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((<.>))
import System.IO (Handle, IOMode(ReadMode, WriteMode),
hClose, hGetContents, hPutChar,
stdin, stdout, withFile)
import System.IO.Temp (withSystemTempFile)
import System.Process (runInteractiveProcess,
waitForProcess)
renderCompactDot :: (PrintDotRepr dg n) => dg n -> Text
renderCompactDot :: forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> Text
renderCompactDot = SimpleDoc -> Text
displayT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> SimpleDoc
renderOneLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Doc
runDotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrintDot a => a -> DotCode
toDot
toUTF8 :: ByteString -> Text
toUTF8 :: ByteString -> Text
toUTF8 = forall e1 e2 a.
(Exception e1, Exception e2) =>
(e1 -> e2) -> a -> a
mapException UnicodeException -> GraphvizException
fE forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8
where
fE :: UnicodeException -> GraphvizException
fE :: UnicodeException -> GraphvizException
fE UnicodeException
e = String -> GraphvizException
NotUTF8Dot forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
e
hPutDot :: (PrintDotRepr dg n) => Handle -> dg n -> IO ()
hPutDot :: forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutDot = forall (dg :: * -> *) n. (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> Text
printDotGraph
hPutCompactDot :: (PrintDotRepr dg n) => Handle -> dg n -> IO ()
hPutCompactDot :: forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutCompactDot = forall (dg :: * -> *) n. (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> Text
renderCompactDot
toHandle :: (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle :: forall (dg :: * -> *) n. (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle dg n -> Text
f Handle
h dg n
dg = do Handle -> ByteString -> IO ()
B.hPutStr Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ dg n -> Text
f dg n
dg
Handle -> Char -> IO ()
hPutChar Handle
h Char
'\n'
hGetStrict :: Handle -> IO Text
hGetStrict :: Handle -> IO Text
hGetStrict = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> Text
toUTF8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ByteString
SB.hGetContents
hGetDot :: (ParseDotRepr dg n) => Handle -> IO (dg n)
hGetDot :: forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (dg :: * -> *) n. ParseDotRepr dg n => Text -> dg n
parseDotGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Text
hGetStrict
writeDotFile :: (PrintDotRepr dg n) => FilePath -> dg n -> IO ()
writeDotFile :: forall (dg :: * -> *) n.
PrintDotRepr dg n =>
String -> dg n -> IO ()
writeDotFile String
f = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
WriteMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutDot
readDotFile :: (ParseDotRepr dg n) => FilePath -> IO (dg n)
readDotFile :: forall (dg :: * -> *) n. ParseDotRepr dg n => String -> IO (dg n)
readDotFile String
f = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
ReadMode forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot
putDot :: (PrintDotRepr dg n) => dg n -> IO ()
putDot :: forall (dg :: * -> *) n. PrintDotRepr dg n => dg n -> IO ()
putDot = forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutDot Handle
stdout
readDot :: (ParseDotRepr dg n) => IO (dg n)
readDot :: forall (dg :: * -> *) n. ParseDotRepr dg n => IO (dg n)
readDot = forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot Handle
stdin
runCommand :: (PrintDotRepr dg n)
=> String
-> [String]
-> (Handle -> IO a)
-> dg n
-> IO a
runCommand :: forall (dg :: * -> *) n a.
PrintDotRepr dg n =>
String -> [String] -> (Handle -> IO a) -> dg n -> IO a
runCommand String
cmd [String]
args Handle -> IO a
hf dg n
dg
= forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> GraphvizException
notRunnable) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
"graphviz" String -> String -> String
<.> String
"gv") forall a b. (a -> b) -> a -> b
$ \String
dotFile Handle
dotHandle -> do
forall a b. IO a -> IO b -> IO a
finally (forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutCompactDot Handle
dotHandle dg n
dg) (Handle -> IO ()
hClose Handle
dotHandle)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
cmd ([String]
args forall a. [a] -> [a] -> [a]
++ [String
dotFile]) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
(\(Handle
inh,Handle
outh,Handle
errh,ProcessHandle
_) -> Handle -> IO ()
hClose Handle
inh forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
outh forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
errh)
forall a b. (a -> b) -> a -> b
$ \(Handle
inp,Handle
outp,Handle
errp,ProcessHandle
prc) -> do
Handle -> IO ()
hClose Handle
inp
MVar a
mvOutput <- forall a. IO (MVar a)
newEmptyMVar
MVar String
mvErr <- forall a. IO (MVar a)
newEmptyMVar
IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. (Handle -> IO a) -> Handle -> MVar a -> IO ()
signalWhenDone Handle -> IO String
hGetContents' Handle
errp MVar String
mvErr
IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. (Handle -> IO a) -> Handle -> MVar a -> IO ()
signalWhenDone Handle -> IO a
hf' Handle
outp MVar a
mvOutput
String
err <- forall a. MVar a -> IO a
takeMVar MVar String
mvErr
a
output <- forall a. MVar a -> IO a
takeMVar MVar a
mvOutput
ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
prc
case ExitCode
exitCode of
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return a
output
ExitCode
_ -> forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GraphvizException
GVProgramExc forall a b. (a -> b) -> a -> b
$ String
othErr forall a. [a] -> [a] -> [a]
++ String
err
where
notRunnable :: IOException -> GraphvizException
notRunnable :: IOException -> GraphvizException
notRunnable IOException
e = String -> GraphvizException
GVProgramExc forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"Unable to call the command "
, String
cmd
, String
" with the arguments: \""
, [String] -> String
unwords [String]
args
, String
"\" because of: "
, forall a. Show a => a -> String
show IOException
e
]
hf' :: Handle -> IO a
hf' = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> GraphvizException
fErr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO a
hf
fErr :: IOException -> GraphvizException
fErr :: IOException -> GraphvizException
fErr IOException
e = String -> GraphvizException
GVProgramExc forall a b. (a -> b) -> a -> b
$ String
"Error re-directing the output from "
forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e
othErr :: String
othErr = String
"Error messages from " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
":\n"
hGetContents' :: Handle -> IO String
hGetContents' :: Handle -> IO String
hGetContents' Handle
h = do String
r <- Handle -> IO String
hGetContents Handle
h
forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
r
forall (m :: * -> *) a. Monad m => a -> m a
return String
r
signalWhenDone :: (Handle -> IO a) -> Handle -> MVar a -> IO ()
signalWhenDone :: forall a. (Handle -> IO a) -> Handle -> MVar a -> IO ()
signalWhenDone Handle -> IO a
f Handle
h MVar a
mv = Handle -> IO a
f Handle
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar a
mv forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()