{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Language.PlantUML.Call
Description : A simple library to call PlantUML given a diagram specification
Copyright   : (c) Marcellus Siegburg, 2022
License     : MIT
Maintainer  : marcellus.siegburg@uni-due.de

This module provides the basic functionality to call PlantUML.
-}
module Language.PlantUML.Call (
  DiagramType (..),
  drawPlantUMLDiagram,
  ) where

import Paths_call_plantuml (getDataDir)

import qualified Data.ByteString.Char8            as BS (
  dropWhile,
  head,
  null,
  putStrLn,
  tail,
  )

import Control.Concurrent (
  forkIO, killThread, newEmptyMVar, putMVar, takeMVar,
  )
import Control.Monad                    (unless, when)
import Data.ByteString                  (ByteString, hGetContents, hPutStr)
import Data.ByteString.Char8            (unpack)
import System.Exit                      (ExitCode (..))
import System.FilePath
  ((</>), (<.>))
import System.IO (
  hClose,
  hFlush,
#ifndef mingw32_HOST_OS
  BufferMode (NoBuffering),
  hSetBuffering,
#endif
  )
import System.Process (
  CreateProcess (..), StdStream (..),
  createProcess, proc, waitForProcess,
  )

{-|
An output format for PlantUML.
-}
data DiagramType =
  ASCIIArt |
  ASCIIArtUnicode |
  EPS |
  LaTeX |
  LaTeXFull |
  PNG |
  SVG |
  VDX
  deriving (DiagramType
DiagramType -> DiagramType -> Bounded DiagramType
forall a. a -> a -> Bounded a
maxBound :: DiagramType
$cmaxBound :: DiagramType
minBound :: DiagramType
$cminBound :: DiagramType
Bounded, Int -> DiagramType
DiagramType -> Int
DiagramType -> [DiagramType]
DiagramType -> DiagramType
DiagramType -> DiagramType -> [DiagramType]
DiagramType -> DiagramType -> DiagramType -> [DiagramType]
(DiagramType -> DiagramType)
-> (DiagramType -> DiagramType)
-> (Int -> DiagramType)
-> (DiagramType -> Int)
-> (DiagramType -> [DiagramType])
-> (DiagramType -> DiagramType -> [DiagramType])
-> (DiagramType -> DiagramType -> [DiagramType])
-> (DiagramType -> DiagramType -> DiagramType -> [DiagramType])
-> Enum DiagramType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DiagramType -> DiagramType -> DiagramType -> [DiagramType]
$cenumFromThenTo :: DiagramType -> DiagramType -> DiagramType -> [DiagramType]
enumFromTo :: DiagramType -> DiagramType -> [DiagramType]
$cenumFromTo :: DiagramType -> DiagramType -> [DiagramType]
enumFromThen :: DiagramType -> DiagramType -> [DiagramType]
$cenumFromThen :: DiagramType -> DiagramType -> [DiagramType]
enumFrom :: DiagramType -> [DiagramType]
$cenumFrom :: DiagramType -> [DiagramType]
fromEnum :: DiagramType -> Int
$cfromEnum :: DiagramType -> Int
toEnum :: Int -> DiagramType
$ctoEnum :: Int -> DiagramType
pred :: DiagramType -> DiagramType
$cpred :: DiagramType -> DiagramType
succ :: DiagramType -> DiagramType
$csucc :: DiagramType -> DiagramType
Enum, ReadPrec [DiagramType]
ReadPrec DiagramType
Int -> ReadS DiagramType
ReadS [DiagramType]
(Int -> ReadS DiagramType)
-> ReadS [DiagramType]
-> ReadPrec DiagramType
-> ReadPrec [DiagramType]
-> Read DiagramType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DiagramType]
$creadListPrec :: ReadPrec [DiagramType]
readPrec :: ReadPrec DiagramType
$creadPrec :: ReadPrec DiagramType
readList :: ReadS [DiagramType]
$creadList :: ReadS [DiagramType]
readsPrec :: Int -> ReadS DiagramType
$creadsPrec :: Int -> ReadS DiagramType
Read, Int -> DiagramType -> ShowS
[DiagramType] -> ShowS
DiagramType -> String
(Int -> DiagramType -> ShowS)
-> (DiagramType -> String)
-> ([DiagramType] -> ShowS)
-> Show DiagramType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiagramType] -> ShowS
$cshowList :: [DiagramType] -> ShowS
show :: DiagramType -> String
$cshow :: DiagramType -> String
showsPrec :: Int -> DiagramType -> ShowS
$cshowsPrec :: Int -> DiagramType -> ShowS
Show)

typeShortName :: DiagramType -> String
typeShortName :: DiagramType -> String
typeShortName DiagramType
x = case DiagramType
x of
  DiagramType
ASCIIArt          -> String
"txt"
  DiagramType
ASCIIArtUnicode   -> String
"utxt"
  DiagramType
EPS               -> String
"eps"
  DiagramType
LaTeX             -> String
"latex"
  DiagramType
LaTeXFull         -> String
"latex:nopreamble"
  DiagramType
PNG               -> String
"png"
  DiagramType
SVG               -> String
"svg"
  DiagramType
VDX               -> String
"vdx"

{-|
This function may be used to draw a PlantUML diagram given a valid
specification and a return type.
It calls PlantUML via Java.
-}
drawPlantUMLDiagram
  :: DiagramType
  -- ^ The return type of diagram to return
  -> ByteString
  -- ^ The PlantUML diagram specification which should be loaded
  -> IO ByteString
drawPlantUMLDiagram :: DiagramType -> ByteString -> IO ByteString
drawPlantUMLDiagram DiagramType
what ByteString
content = do
  String
dataDir <- IO String
getDataDir
  let callPlantUML :: CreateProcess
callPlantUML = String -> [String] -> CreateProcess
proc String
"java" [
        String
"-jar", String
dataDir String -> ShowS
</> String
"plantuml" String -> ShowS
<.> String
"jar",
        String
"-p", String
"-t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DiagramType -> String
typeShortName DiagramType
what, String
"-nometadata", String
"-noerror"
        ]
  (Just Handle
hin, Just Handle
hout, Just Handle
herr, ProcessHandle
ph) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
callPlantUML {
        std_out :: StdStream
std_out = StdStream
CreatePipe,
        std_in :: StdStream
std_in  = StdStream
CreatePipe,
        std_err :: StdStream
std_err = StdStream
CreatePipe
      }
  (ThreadId, MVar ByteString)
pout <- Handle -> IO (ThreadId, MVar ByteString)
listenForOutput Handle
hout
  (ThreadId, MVar ByteString)
perr <- Handle -> IO (ThreadId, MVar ByteString)
listenForOutput Handle
herr
#ifndef mingw32_HOST_OS
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
#endif
  Handle -> ByteString -> IO ()
hPutStr Handle
hin ByteString
content
  Handle -> IO ()
hFlush Handle
hin
  Handle -> IO ()
hClose Handle
hin
  ByteString
out <- (ThreadId, MVar ByteString) -> IO ByteString
forall b. (ThreadId, MVar b) -> IO b
getOutput (ThreadId, MVar ByteString)
pout
  ByteString
err <- (ThreadId, MVar ByteString) -> IO ByteString
forall b. (ThreadId, MVar b) -> IO b
getOutput (ThreadId, MVar ByteString)
perr
  ProcessHandle -> ByteString -> IO ()
printContentOnError ProcessHandle
ph ByteString
out
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
err) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack ByteString
err
  ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
  where
    printContentOnError :: ProcessHandle -> ByteString -> IO ()
printContentOnError ProcessHandle
ph ByteString
out = do
      ExitCode
code <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure Int
1 Bool -> Bool -> Bool
|| ByteString -> Bool
isError ByteString
out)
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BS.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Error on calling PlantUML with:\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
content
    listenForOutput :: Handle -> IO (ThreadId, MVar ByteString)
listenForOutput Handle
h = do
      MVar ByteString
mvar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
      ThreadId
pid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
hGetContents Handle
h IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
mvar
      (ThreadId, MVar ByteString) -> IO (ThreadId, MVar ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
pid, MVar ByteString
mvar)
    getOutput :: (ThreadId, MVar b) -> IO b
getOutput (ThreadId
pid, MVar b
mvar) = do
      b
output <- MVar b -> IO b
forall a. MVar a -> IO a
takeMVar MVar b
mvar
      ThreadId -> IO ()
killThread ThreadId
pid
      b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
output

isError :: ByteString -> Bool
isError :: ByteString -> Bool
isError ByteString
xs =
  let ys :: ByteString
ys = (Char -> Bool) -> ByteString -> ByteString
BS.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
xs
      zs :: ByteString
zs = (Char -> Bool) -> ByteString -> ByteString
BS.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.tail ByteString
ys
  in Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
ys)
  Bool -> Bool -> Bool
&& ByteString -> Char
BS.head ByteString
ys Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
  Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
zs)
  Bool -> Bool -> Bool
&& ByteString -> Char
BS.head ByteString
zs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'