{-# 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,
  drawPlantUMLDiagram,
  ) where

import Paths_call_plantuml (getDataDir)

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

import Control.Concurrent.Async         (concurrently)
import Control.Exception                (bracket)
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 (
  Handle,
  hClose,
  hFlush,
#ifndef mingw32_HOST_OS
  BufferMode (NoBuffering),
  hSetBuffering,
#endif
  )
import System.Process (
  CreateProcess (..),
  ProcessHandle,
  StdStream (..),
  cleanupProcess,
  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
$cminBound :: DiagramType
minBound :: DiagramType
$cmaxBound :: DiagramType
maxBound :: 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
$csucc :: DiagramType -> DiagramType
succ :: DiagramType -> DiagramType
$cpred :: DiagramType -> DiagramType
pred :: DiagramType -> DiagramType
$ctoEnum :: Int -> DiagramType
toEnum :: Int -> DiagramType
$cfromEnum :: DiagramType -> Int
fromEnum :: DiagramType -> Int
$cenumFrom :: DiagramType -> [DiagramType]
enumFrom :: DiagramType -> [DiagramType]
$cenumFromThen :: DiagramType -> DiagramType -> [DiagramType]
enumFromThen :: DiagramType -> DiagramType -> [DiagramType]
$cenumFromTo :: DiagramType -> DiagramType -> [DiagramType]
enumFromTo :: DiagramType -> DiagramType -> [DiagramType]
$cenumFromThenTo :: DiagramType -> DiagramType -> DiagramType -> [DiagramType]
enumFromThenTo :: DiagramType -> DiagramType -> 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
$creadsPrec :: Int -> ReadS DiagramType
readsPrec :: Int -> ReadS DiagramType
$creadList :: ReadS [DiagramType]
readList :: ReadS [DiagramType]
$creadPrec :: ReadPrec DiagramType
readPrec :: ReadPrec DiagramType
$creadListPrec :: ReadPrec [DiagramType]
readListPrec :: ReadPrec [DiagramType]
Read, Int -> DiagramType -> ShowS
[DiagramType] -> ShowS
DiagramType -> [Char]
(Int -> DiagramType -> ShowS)
-> (DiagramType -> [Char])
-> ([DiagramType] -> ShowS)
-> Show DiagramType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiagramType -> ShowS
showsPrec :: Int -> DiagramType -> ShowS
$cshow :: DiagramType -> [Char]
show :: DiagramType -> [Char]
$cshowList :: [DiagramType] -> ShowS
showList :: [DiagramType] -> ShowS
Show)

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

{-|
Calls PlantUml (Java) using the given 'DiagramType'.
Assures proper closing of the processes.
-}
callPlantUml
  :: DiagramType
  -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a)
  -> IO a
callPlantUml :: forall a.
DiagramType
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
callPlantUml DiagramType
what = (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
     -> IO ())
 -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
     -> IO a)
 -> IO a)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
     -> IO a)
 -> IO a)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ do
  [Char]
dataDir <- IO [Char]
getDataDir
  let callPlantUML :: CreateProcess
callPlantUML = [Char] -> [[Char]] -> CreateProcess
proc [Char]
"java" [
        [Char]
"-Djava.awt.headless=true",
        [Char]
"-jar", [Char]
dataDir [Char] -> ShowS
</> [Char]
"plantuml" [Char] -> ShowS
<.> [Char]
"jar",
        [Char]
"-p", [Char]
"-t" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ DiagramType -> [Char]
typeShortName DiagramType
what, [Char]
"-nometadata", [Char]
"-noerror"
        ]
  CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
callPlantUML {
    std_out = CreatePipe,
    std_in  = CreatePipe,
    std_err = CreatePipe
    }

{-|
A synonym for 'drawPlantUmlDiagram'.
-}
drawPlantUMLDiagram :: DiagramType -> ByteString -> IO ByteString
drawPlantUMLDiagram :: DiagramType -> ByteString -> IO ByteString
drawPlantUMLDiagram = DiagramType -> ByteString -> IO ByteString
drawPlantUmlDiagram

{-|
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 = DiagramType
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ByteString)
-> IO ByteString
forall a.
DiagramType
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
callPlantUml DiagramType
what (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
  -> IO ByteString)
 -> IO ByteString)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ByteString)
-> IO ByteString
forall a b. (a -> b) -> a -> b
$ \(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p -> do
  (Just Handle
hin, Just Handle
hout, Just Handle
herr, ProcessHandle
ph) <- (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p
#ifndef mingw32_HOST_OS
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
#endif
  let evaluatePlantUml :: IO ()
evaluatePlantUml = do
        Handle -> ByteString -> IO ()
hPutStr Handle
hin ByteString
content
        Handle -> IO ()
hFlush Handle
hin
        Handle -> IO ()
hClose Handle
hin
  (ByteString
out, ByteString
err) <- ((ByteString, ByteString), ()) -> (ByteString, ByteString)
forall a b. (a, b) -> a
fst (((ByteString, ByteString), ()) -> (ByteString, ByteString))
-> IO ((ByteString, ByteString), ()) -> IO (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (ByteString, ByteString)
-> IO () -> IO ((ByteString, ByteString), ())
forall a b. IO a -> IO b -> IO (a, b)
concurrently
    (IO ByteString -> IO ByteString -> IO (ByteString, ByteString)
forall a b. IO a -> IO b -> IO (a, b)
concurrently (Handle -> IO ByteString
hGetContents Handle
hout) (Handle -> IO ByteString
hGetContents Handle
herr))
    IO ()
evaluatePlantUml
  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
$ [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
err
  ByteString -> IO ByteString
forall a. a -> IO a
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
/= ExitCode
ExitSuccess 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

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
$ HasCallStack => ByteString -> ByteString
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'