    {-# 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 ()