{-# 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 (SimpleDoc -> Text) -> (dg n -> SimpleDoc) -> dg n -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> SimpleDoc
renderOneLine
                   (Doc -> SimpleDoc) -> (dg n -> Doc) -> dg n -> SimpleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Doc
runDotCode
                   (DotCode -> Doc) -> (dg n -> DotCode) -> dg n -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dg n -> DotCode
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 = (UnicodeException -> GraphvizException) -> Text -> Text
forall e1 e2 a.
(Exception e1, Exception e2) =>
(e1 -> e2) -> a -> a
mapException UnicodeException -> GraphvizException
fE (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
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 (String -> GraphvizException) -> String -> GraphvizException
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
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 = (dg n -> Text) -> Handle -> dg n -> IO ()
forall (dg :: * -> *) n. (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle dg n -> Text
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 = (dg n -> Text) -> Handle -> dg n -> IO ()
forall (dg :: * -> *) n. (dg n -> Text) -> Handle -> dg n -> IO ()
toHandle dg n -> Text
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 (ByteString -> IO ()) -> (Text -> ByteString) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> IO ()) -> Text -> IO ()
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 = (StrictByteString -> Text) -> IO StrictByteString -> IO Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> Text
toUTF8 (ByteString -> Text)
-> (StrictByteString -> ByteString) -> StrictByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StrictByteString] -> ByteString
B.fromChunks ([StrictByteString] -> ByteString)
-> (StrictByteString -> [StrictByteString])
-> StrictByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
:[]))
             (IO StrictByteString -> IO Text)
-> (Handle -> IO StrictByteString) -> Handle -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO StrictByteString
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 = (Text -> dg n) -> IO Text -> IO (dg n)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> dg n
forall (dg :: * -> *) n. ParseDotRepr dg n => Text -> dg n
parseDotGraph (IO Text -> IO (dg n))
-> (Handle -> IO Text) -> Handle -> IO (dg n)
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 = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
WriteMode ((Handle -> IO ()) -> IO ())
-> (dg n -> Handle -> IO ()) -> dg n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> dg n -> IO ()) -> dg n -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> dg n -> IO ()
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 = String -> IOMode -> (Handle -> IO (dg n)) -> IO (dg n)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
ReadMode Handle -> IO (dg n)
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 = Handle -> dg n -> IO ()
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 = Handle -> IO (dg n)
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
  = (IOException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (GraphvizException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (GraphvizException -> IO a)
-> (IOException -> GraphvizException) -> IOException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> GraphvizException
notRunnable) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
    String -> (String -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile (String
"graphviz" String -> String -> String
<.> String
"gv") ((String -> Handle -> IO a) -> IO a)
-> (String -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
dotFile Handle
dotHandle -> do
      IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (Handle -> dg n -> IO ()
forall (dg :: * -> *) n.
PrintDotRepr dg n =>
Handle -> dg n -> IO ()
hPutCompactDot Handle
dotHandle dg n
dg) (Handle -> IO ()
hClose Handle
dotHandle)
      IO (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO ())
-> ((Handle, Handle, Handle, ProcessHandle) -> IO a)
-> IO a
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
dotFile]) Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing)
        (\(Handle
inh,Handle
outh,Handle
errh,ProcessHandle
_) -> Handle -> IO ()
hClose Handle
inh IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
outh IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
errh)
        (((Handle, Handle, Handle, ProcessHandle) -> IO a) -> IO a)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO a) -> IO a
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.
          mvOutput <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
          mvErr    <- newEmptyMVar

          forkIO $ signalWhenDone hGetContents' errp mvErr
          forkIO $ signalWhenDone hf' outp mvOutput

          -- When these are both able to be taken, then the forks are finished
          err <- takeMVar mvErr
          output <- takeMVar mvOutput

          exitCode <- waitForProcess prc

          case exitCode of
            ExitCode
ExitSuccess -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
output
            ExitCode
_           -> GraphvizException -> IO a
forall a e. (HasCallStack, Exception e) => e -> a
throw (GraphvizException -> IO a)
-> (String -> GraphvizException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GraphvizException
GVProgramExc (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
othErr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
  where
    notRunnable   :: IOException -> GraphvizException
    notRunnable :: IOException -> GraphvizException
notRunnable IOException
e = String -> GraphvizException
GVProgramExc (String -> GraphvizException) -> String -> GraphvizException
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: "
                    , IOException -> String
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' = (IOException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (GraphvizException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (GraphvizException -> IO a)
-> (IOException -> GraphvizException) -> IOException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> GraphvizException
fErr) (IO a -> IO a) -> (Handle -> IO a) -> Handle -> IO a
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 (String -> GraphvizException) -> String -> GraphvizException
forall a b. (a -> b) -> a -> b
$ String
"Error re-directing the output from "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e

    othErr :: String
othErr = String
"Error messages from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
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 r <- Handle -> IO String
hGetContents Handle
h
                     evaluate $ length r
                     return 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 IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mv IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()