{-# LANGUAGE MultiParamTypeClasses #-}

{- |
   Module      : Data.GraphViz.Commands.IO
   Description : IO-related functions for graphviz.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   Various utility functions to help with custom I\/O of Dot code.
-}
module Data.GraphViz.Commands.IO
       ( -- * Encoding
         -- $encoding
         toUTF8
         -- * Operations on files
       , writeDotFile
       , readDotFile
         -- * Operations on handles
       , hPutDot
       , hPutCompactDot
       , hGetDot
       , hGetStrict
         -- * Special cases for standard input and output
       , putDot
       , readDot
         -- * Running external commands
       , 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)


-- -----------------------------------------------------------------------------

-- | Correctly render Graphviz output in a more machine-oriented form
--   (i.e. more compact than the output of 'renderDot').
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

-- -----------------------------------------------------------------------------
-- Encoding

{- $encoding
  By default, Dot code should be in UTF-8.  However, by usage of the
  /charset/ attribute, users are able to specify that the ISO-8859-1
  (aka Latin1) encoding should be used instead:
  <http://www.graphviz.org/doc/info/attrs.html#d:charset>

  To simplify matters, graphviz does /not/ work with ISO-8859-1.  If
  you wish to deal with existing Dot code that uses this encoding, you
  will need to manually read that file in to a 'Text' value.

  If a non-UTF-8 encoding is used, then a 'GraphvizException' will
  be thrown.
-}

-- | Explicitly convert a (lazy) 'ByteString' to a 'Text' value using
--   UTF-8 encoding, throwing a 'GraphvizException' if there is a
--   decoding error.
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

-- -----------------------------------------------------------------------------
-- Low-level Input/Output

-- | Output the @DotRepr@ to the specified 'Handle'.
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

-- | Output the @DotRepr@ to the spcified 'Handle' in a more compact,
--   machine-oriented form.
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'

-- | Strictly read in a 'Text' value using an appropriate encoding.
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

-- | Read in and parse a @DotRepr@ value from the specified 'Handle'.
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

-- | Write the specified @DotRepr@ to file.
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

-- | Read in and parse a @DotRepr@ value from a file.
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

-- | Print the specified @DotRepr@ to 'stdout'.
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

-- | Read in and parse a @DotRepr@ value from 'stdin'.
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

-- -----------------------------------------------------------------------------

-- | Run an external command on the specified @DotRepr@.  Remember to
--   use 'hSetBinaryMode' on the 'Handle' for the output function if
--   necessary.
--
--   If the command was unsuccessful, then a 'GraphvizException' is
--   thrown.
--
--   For performance reasons, a temporary file is used to store the
--   generated Dot code.  As such, this is only suitable for local
--   commands.
runCommand :: (PrintDotRepr dg n)
              => String           -- ^ Command to run
              -> [String]         -- ^ Command-line arguments
              -> (Handle -> IO a) -- ^ Obtaining the output; should be strict.
              -> 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

          -- Not using it, so close it off directly.
          Handle -> IO ()
hClose Handle
inp

          -- Need to make sure both the output and error handles are
          -- really fully consumed.
          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

          -- When these are both able to be taken, then the forks are finished
          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
                    ]

    -- Augmenting the hf function to let it work within the forkIO:
    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"

-- -----------------------------------------------------------------------------
-- Utility functions

-- | A version of 'hGetContents' that fully evaluates the contents of
--   the 'Handle' (that is, until EOF is reached).  The 'Handle' is
--   not closed.
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

-- | Store the result of the 'Handle' consumption into the 'MVar'.
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 ()