{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving,
             OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
   Module      : Data.GraphViz.Printing
   Description : Helper functions for converting to Dot format.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module defines simple helper functions for use with
   "Text.PrettyPrint".  It also re-exports all the pretty-printing
   combinators from that module.

   Note that the 'PrintDot' instances for 'Bool', etc. match those
   specified for use with Graphviz.

   You should only be using this module if you are writing custom node
   types for use with "Data.GraphViz.Types".  For actual printing of
   code, use @'Data.GraphViz.Types.printDotGraph'@ (which produces a
   'Text' value).

   The Dot language specification specifies that any identifier is in
   one of four forms:

       * Any string of alphabetic ([a-zA-Z\\200-\\377]) characters,
         underscores ('_') or digits ([0-9]), not beginning with a
         digit;

       * a number [-]?(.[0-9]+ | [0-9]+(.[0-9]*)? );

       * any double-quoted string (\"...\") possibly containing
         escaped quotes (\\\");

       * an HTML string (\<...\>).

   (Note that the first restriction is referring to a byte-by-byte
   comparison using octal values; when using UTF-8 this corresponds to
   all characters @c@ where @ord c >= 128@.)

   Due to these restrictions, you should only use 'text' when you are
   sure that the 'Text' in question is static and quotes are
   definitely needed/unneeded; it is better to use the 'Text'
   instance for 'PrintDot'.  For more information, see the
   specification page:
      <http://graphviz.org/doc/info/lang.html>
-}
module Data.GraphViz.Printing
    ( module Text.PrettyPrint.Leijen.Text.Monadic
    , DotCode
    , DotCodeM
    , runDotCode
    , renderDot -- Exported for Data.GraphViz.Types.Internal.Common.printSGID
    , PrintDot(..)
    , unqtText
    , dotText
    , printIt
    , addQuotes
    , unqtEscaped
    , printEscaped
    , wrap
    , commaDel
    , printField
    , angled
    , fslash
    , printColorScheme
    ) where

import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util
-- To avoid orphan instances and cyclic imports
import Data.GraphViz.Attributes.ColorScheme

-- Only implicitly import and re-export combinators.
import qualified Data.Text                            as ST
import           Data.Text.Lazy                       (Text)
import qualified Data.Text.Lazy                       as T
import           Text.PrettyPrint.Leijen.Text.Monadic hiding (Pretty(..),
                                                       SimpleDoc(..), bool,
                                                       displayIO, displayT,
                                                       hPutDoc, putDoc,
                                                       renderCompact,
                                                       renderPretty, string,
                                                       width, (<$>))
import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP

import           Control.Monad       (ap, when)
import           Control.Monad.State (MonadState, State, evalState, gets,
                                      modify)
import           Data.Char           (toLower)
import qualified Data.Set            as Set
import           Data.String         (IsString(..))
import           Data.Version        (Version(..))
import           Data.Word           (Word16, Word8)

#if !(MIN_VERSION_base (4,11,0))

#if !(MIN_VERSION_base (4,8,0))
import Control.Applicative (Applicative)
import Data.Monoid         (Monoid(..))
#endif

#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)
import Data.Semigroup (Semigroup(..))
#else
import Data.Monoid ((<>))
#endif

#endif

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

-- | A type alias to indicate what is being produced.
newtype DotCodeM a = DotCodeM { DotCodeM a -> State GraphvizState a
getDotCode :: State GraphvizState a }
  deriving (a -> DotCodeM b -> DotCodeM a
(a -> b) -> DotCodeM a -> DotCodeM b
(forall a b. (a -> b) -> DotCodeM a -> DotCodeM b)
-> (forall a b. a -> DotCodeM b -> DotCodeM a) -> Functor DotCodeM
forall a b. a -> DotCodeM b -> DotCodeM a
forall a b. (a -> b) -> DotCodeM a -> DotCodeM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DotCodeM b -> DotCodeM a
$c<$ :: forall a b. a -> DotCodeM b -> DotCodeM a
fmap :: (a -> b) -> DotCodeM a -> DotCodeM b
$cfmap :: forall a b. (a -> b) -> DotCodeM a -> DotCodeM b
Functor, Functor DotCodeM
a -> DotCodeM a
Functor DotCodeM =>
(forall a. a -> DotCodeM a)
-> (forall a b. DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b)
-> (forall a b c.
    (a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c)
-> (forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b)
-> (forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a)
-> Applicative DotCodeM
DotCodeM a -> DotCodeM b -> DotCodeM b
DotCodeM a -> DotCodeM b -> DotCodeM a
DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
(a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
forall a. a -> DotCodeM a
forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
forall a b. DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
forall a b c.
(a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DotCodeM a -> DotCodeM b -> DotCodeM a
$c<* :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
*> :: DotCodeM a -> DotCodeM b -> DotCodeM b
$c*> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
liftA2 :: (a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
<*> :: DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
$c<*> :: forall a b. DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
pure :: a -> DotCodeM a
$cpure :: forall a. a -> DotCodeM a
$cp1Applicative :: Functor DotCodeM
Applicative, Applicative DotCodeM
a -> DotCodeM a
Applicative DotCodeM =>
(forall a b. DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b)
-> (forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b)
-> (forall a. a -> DotCodeM a)
-> Monad DotCodeM
DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
DotCodeM a -> DotCodeM b -> DotCodeM b
forall a. a -> DotCodeM a
forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
forall a b. DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DotCodeM a
$creturn :: forall a. a -> DotCodeM a
>> :: DotCodeM a -> DotCodeM b -> DotCodeM b
$c>> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
>>= :: DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
$c>>= :: forall a b. DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
$cp1Monad :: Applicative DotCodeM
Monad, MonadState GraphvizState)

type DotCode = DotCodeM Doc

runDotCode :: DotCode -> Doc
runDotCode :: DotCode -> Doc
runDotCode = (State GraphvizState Doc -> GraphvizState -> Doc
forall s a. State s a -> s -> a
`evalState` GraphvizState
initialState) (State GraphvizState Doc -> Doc)
-> (DotCode -> State GraphvizState Doc) -> DotCode -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> State GraphvizState Doc
forall a. DotCodeM a -> State GraphvizState a
getDotCode

instance Show DotCode where
  showsPrec :: Int -> DotCode -> ShowS
showsPrec d :: Int
d = Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Text -> ShowS) -> (DotCode -> Text) -> DotCode -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Text
renderDot

instance IsString DotCode where
  fromString :: String -> DotCode
fromString = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
PP.string (Text -> DotCode) -> (String -> Text) -> String -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

#if MIN_VERSION_base (4,9,0)
instance Semigroup DotCode where
  <> :: DotCode -> DotCode -> DotCode
(<>) = DotCode -> DotCode -> DotCode
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
beside

instance Monoid DotCode where
  mempty :: DotCode
mempty  = DotCode
forall (m :: * -> *). Applicative m => m Doc
empty
  mappend :: DotCode -> DotCode -> DotCode
mappend = DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
(<>)
#else
instance Monoid DotCode where
  mempty  = empty
  mappend = beside
#endif

instance GraphvizStateM DotCodeM where
  modifyGS :: (GraphvizState -> GraphvizState) -> DotCodeM ()
modifyGS = (GraphvizState -> GraphvizState) -> DotCodeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify

  getsGS :: (GraphvizState -> a) -> DotCodeM a
getsGS = (GraphvizState -> a) -> DotCodeM a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets

-- | Correctly render Graphviz output.
renderDot :: DotCode -> Text
renderDot :: DotCode -> Text
renderDot = SimpleDoc -> Text
PP.displayT (SimpleDoc -> Text) -> (DotCode -> SimpleDoc) -> DotCode -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Int -> Doc -> SimpleDoc
PP.renderPretty 0.4 80
            (Doc -> SimpleDoc) -> (DotCode -> Doc) -> DotCode -> SimpleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> Doc
runDotCode

-- | A class used to correctly print parts of the Graphviz Dot language.
--   Minimal implementation is 'unqtDot'.
class PrintDot a where
  -- | The unquoted representation, for use when composing values to
  --   produce a larger printing value.
  unqtDot :: a -> DotCode

  -- | The actual quoted representation; this should be quoted if it
  --   contains characters not permitted a plain ID String, a number
  --   or it is not an HTML string.  Defaults to 'unqtDot'.
  toDot :: a -> DotCode
  toDot = a -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

  -- | The correct way of representing a list of this value when
  --   printed; not all Dot values require this to be implemented.
  --   Defaults to Haskell-like list representation.
  unqtListToDot :: [a] -> DotCode
  unqtListToDot = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
list (DotCodeM [Doc] -> DotCode)
-> ([a] -> DotCodeM [Doc]) -> [a] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> DotCode) -> [a] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

  -- | The quoted form of 'unqtListToDot'; defaults to wrapping double
  --   quotes around the result of 'unqtListToDot' (since the default
  --   implementation has characters that must be quoted).
  listToDot :: [a] -> DotCode
  listToDot = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> ([a] -> DotCode) -> [a] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot

-- | Convert to DotCode; note that this has no indentation, as we can
--   only have one of indentation and (possibly) infinite line lengths.
printIt :: (PrintDot a) => a -> Text
printIt :: a -> Text
printIt = DotCode -> Text
renderDot (DotCode -> Text) -> (a -> DotCode) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DotCode
forall a. PrintDot a => a -> DotCode
toDot

instance PrintDot Int where
  unqtDot :: Int -> DotCode
unqtDot = Int -> DotCode
forall (m :: * -> *). Applicative m => Int -> m Doc
int

instance PrintDot Integer where
  unqtDot :: Integer -> DotCode
unqtDot = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> (Integer -> Text) -> Integer -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

instance PrintDot Word8 where
  unqtDot :: Word8 -> DotCode
unqtDot = Int -> DotCode
forall (m :: * -> *). Applicative m => Int -> m Doc
int (Int -> DotCode) -> (Word8 -> Int) -> Word8 -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance PrintDot Word16 where
  unqtDot :: Word16 -> DotCode
unqtDot = Int -> DotCode
forall (m :: * -> *). Applicative m => Int -> m Doc
int (Int -> DotCode) -> (Word16 -> Int) -> Word16 -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance PrintDot Double where
  -- If it's an "integral" double, then print as an integer.  This
  -- seems to match how Graphviz apps use Dot.
  unqtDot :: Double -> DotCode
unqtDot d :: Double
d = if Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
di
              then Int -> DotCode
forall (m :: * -> *). Applicative m => Int -> m Doc
int Int
di
              else Double -> DotCode
forall (m :: * -> *). Applicative m => Double -> m Doc
double Double
d
      where
        di :: Int
di = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
d

  toDot :: Double -> DotCode
toDot d :: Double
d = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) 'e' (Char -> Bool) -> (Char -> Char) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower) (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
d
            then DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes DotCode
ud
            else DotCode
ud
    where
      ud :: DotCode
ud = Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Double
d

  unqtListToDot :: [Double] -> DotCode
unqtListToDot = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> ([Double] -> DotCodeM [Doc]) -> [Double] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> DotCodeM [Doc] -> DotCodeM [Doc]
forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate DotCode
forall (m :: * -> *). Applicative m => m Doc
colon (DotCodeM [Doc] -> DotCodeM [Doc])
-> ([Double] -> DotCodeM [Doc]) -> [Double] -> DotCodeM [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> DotCode) -> [Double] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

  listToDot :: [Double] -> DotCode
listToDot [d :: Double
d] = Double -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Double
d
  listToDot ds :: [Double]
ds  = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ [Double] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot [Double]
ds

instance PrintDot Bool where
  unqtDot :: Bool -> DotCode
unqtDot True  = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text "true"
  unqtDot False = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text "false"

instance PrintDot Char where
  unqtDot :: Char -> DotCode
unqtDot = Char -> DotCode
forall (m :: * -> *). Applicative m => Char -> m Doc
char

  toDot :: Char -> DotCode
toDot = Char -> DotCode
qtChar

  unqtListToDot :: String -> DotCode
unqtListToDot = Text -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot (Text -> DotCode) -> (String -> Text) -> String -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

  listToDot :: String -> DotCode
listToDot = Text -> DotCode
forall a. PrintDot a => a -> DotCode
toDot (Text -> DotCode) -> (String -> Text) -> String -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Ignores 'versionTags' and assumes 'not . null . versionBranch'
--   (usually you want 'length . versionBranch == 2').
instance PrintDot Version where
  unqtDot :: Version -> DotCode
unqtDot = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> (Version -> DotCodeM [Doc]) -> Version -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> DotCodeM [Doc] -> DotCodeM [Doc]
forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate DotCode
forall (m :: * -> *). Applicative m => m Doc
dot (DotCodeM [Doc] -> DotCodeM [Doc])
-> (Version -> DotCodeM [Doc]) -> Version -> DotCodeM [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> DotCode) -> [Int] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> DotCode
forall (m :: * -> *). Applicative m => Int -> m Doc
int ([Int] -> DotCodeM [Doc])
-> (Version -> [Int]) -> Version -> DotCodeM [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch

  toDot :: Version -> DotCode
toDot v :: Version
v = (DotCode -> DotCode)
-> (DotCode -> DotCode) -> Bool -> DotCode -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode -> DotCode
forall a. a -> a
id DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Bool) -> (Version -> [Int]) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop 2 ([Int] -> [Int]) -> (Version -> [Int]) -> Version -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionBranch (Version -> Bool) -> Version -> Bool
forall a b. (a -> b) -> a -> b
$ Version
v)
            (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ Version -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Version
v

instance PrintDot Text where
  unqtDot :: Text -> DotCode
unqtDot = Text -> DotCode
unqtString

  toDot :: Text -> DotCode
toDot = Text -> DotCode
qtString

instance PrintDot ST.Text where
  unqtDot :: Text -> DotCode
unqtDot = Text -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot (Text -> DotCode) -> (Text -> Text) -> Text -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.fromStrict

  toDot :: Text -> DotCode
toDot = Text -> DotCode
qtString (Text -> DotCode) -> (Text -> Text) -> Text -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.fromStrict

-- | For use with @OverloadedStrings@ to avoid ambiguous type variable errors.
unqtText :: Text -> DotCode
unqtText :: Text -> DotCode
unqtText = Text -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

-- | For use with @OverloadedStrings@ to avoid ambiguous type variable errors.
dotText :: Text -> DotCode
dotText :: Text -> DotCode
dotText = Text -> DotCode
forall a. PrintDot a => a -> DotCode
toDot

-- | Check to see if this 'Char' needs to be quoted or not.
qtChar :: Char -> DotCode
qtChar :: Char -> DotCode
qtChar c :: Char
c
  | Char -> Bool
restIDString Char
c = Char -> DotCode
forall (m :: * -> *). Applicative m => Char -> m Doc
char Char
c -- Could be a number as well.
  | Bool
otherwise      = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ Char -> DotCode
forall (m :: * -> *). Applicative m => Char -> m Doc
char Char
c

needsQuotes :: Text -> Bool
needsQuotes :: Text -> Bool
needsQuotes str :: Text
str
  | Text -> Bool
T.null Text
str            = Bool
True
  | Text -> Bool
isKeyword Text
str         = Bool
True
  | Text -> Bool
isIDString Text
str        = Bool
False
  | Bool -> Text -> Bool
isNumString Bool
False Text
str = Bool
False
  | Bool
otherwise             = Bool
True

addQuotes :: Text -> DotCode -> DotCode
addQuotes :: Text -> DotCode -> DotCode
addQuotes = (DotCode -> DotCode)
-> (DotCode -> DotCode) -> Bool -> DotCode -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode -> DotCode
forall a. a -> a
id DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (Bool -> DotCode -> DotCode)
-> (Text -> Bool) -> Text -> DotCode -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
needsQuotes

-- | Escape quotes in Strings that need them.
unqtString     :: Text -> DotCode
unqtString :: Text -> DotCode
unqtString ""  = DotCode
forall (m :: * -> *). Applicative m => m Doc
empty
unqtString str :: Text
str = String -> Text -> DotCode
unqtEscaped [] Text
str -- no quotes? no worries!

-- | Escape quotes and quote Texts that need them (including keywords).
qtString :: Text -> DotCode
qtString :: Text -> DotCode
qtString = String -> Text -> DotCode
printEscaped []

instance (PrintDot a) => PrintDot [a] where
  unqtDot :: [a] -> DotCode
unqtDot = [a] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot

  toDot :: [a] -> DotCode
toDot = [a] -> DotCode
forall a. PrintDot a => [a] -> DotCode
listToDot

wrap       :: DotCode -> DotCode -> DotCode -> DotCode
wrap :: DotCode -> DotCode -> DotCode -> DotCode
wrap b :: DotCode
b a :: DotCode
a d :: DotCode
d = DotCode
b DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
d DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
a

commaDel     :: (PrintDot a, PrintDot b) => a -> b -> DotCode
commaDel :: a -> b -> DotCode
commaDel a :: a
a b :: b
b = a -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot a
a DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
forall (m :: * -> *). Applicative m => m Doc
comma DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> b -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot b
b

printField     :: (PrintDot a) => Text -> a -> DotCode
printField :: Text -> a -> DotCode
printField f :: Text
f v :: a
v = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
f DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
forall (m :: * -> *). Applicative m => m Doc
equals DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> a -> DotCode
forall a. PrintDot a => a -> DotCode
toDot a
v

-- | Escape the specified chars as well as @\"@.
unqtEscaped    :: [Char] -> Text -> DotCode
unqtEscaped :: String -> Text -> DotCode
unqtEscaped cs :: String
cs = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> (Text -> Text) -> Text -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Text
addEscapes String
cs

-- | Escape the specified chars as well as @\"@ and then wrap the
--   result in quotes.
printEscaped        :: [Char] -> Text -> DotCode
printEscaped :: String -> Text -> DotCode
printEscaped cs :: String
cs str :: Text
str = Text -> DotCode -> DotCode
addQuotes Text
str' (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
str'
  where
    str' :: Text
str' = String -> Text -> Text
addEscapes String
cs Text
str

-- | Ensure the provided characters are all escaped.  Note that we
--   cannot convert to 'DotCode' immediately because 'printEscaped'
--   needs to pass the result from this to 'addQuotes' to determine if
--   it needs to be quoted or not.
addEscapes    :: [Char] -> Text -> Text
addEscapes :: String -> Text -> Text
addEscapes cs :: String
cs = ((Char, Char) -> Text -> Text) -> Text -> [(Char, Char)] -> Text
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Char, Char) -> Text -> Text
escape Text
T.empty ([(Char, Char)] -> Text)
-> (Text -> [(Char, Char)]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [(Char, Char)]
withNext
  where
    cs' :: Set Char
cs' = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList (String -> Set Char) -> String -> Set Char
forall a b. (a -> b) -> a -> b
$ Char
quote Char -> ShowS
forall a. a -> [a] -> [a]
: Char
slash Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
    slash :: Char
slash = '\\'
    quote :: Char
quote = '"'
    escape :: (Char, Char) -> Text -> Text
escape (c :: Char
c,c' :: Char
c') str :: Text
str
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
slash Bool -> Bool -> Bool
&& Char
c' Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Char
escLetters = Char
c Char -> Text -> Text
`T.cons` Text
str
      | Char
c Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Char
cs'                       = Char
slash Char -> Text -> Text
`T.cons` (Char
c Char -> Text -> Text
`T.cons` Text
str)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'                                = Char
slash Char -> Text -> Text
`T.cons` ('n' Char -> Text -> Text
`T.cons` Text
str)
      | Bool
otherwise                                = Char
c Char -> Text -> Text
`T.cons` Text
str

    -- When a slash precedes one of these characters, don't escape the slash.
    escLetters :: Set Char
escLetters = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList ['N', 'G', 'E', 'T', 'H', 'L', 'n', 'l', 'r']

    -- Need to check subsequent characters when escaping slashes, but
    -- don't want to lose the last character when zipping, so append a space.
    withNext :: Text -> [(Char, Char)]
withNext ""  = []
    withNext str :: Text
str = Text -> Text -> [(Char, Char)]
T.zip (Text -> Text -> [(Char, Char)])
-> (Text -> Text) -> Text -> [(Char, Char)]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` ((Text -> Char -> Text
`T.snoc` ' ') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.tail) (Text -> [(Char, Char)]) -> Text -> [(Char, Char)]
forall a b. (a -> b) -> a -> b
$ Text
str

angled :: DotCode -> DotCode
angled :: DotCode -> DotCode
angled = DotCode -> DotCode -> DotCode -> DotCode
wrap DotCode
forall (m :: * -> *). Applicative m => m Doc
langle DotCode
forall (m :: * -> *). Applicative m => m Doc
rangle

fslash :: DotCode
fslash :: DotCode
fslash = Char -> DotCode
forall (m :: * -> *). Applicative m => Char -> m Doc
char '/'

-- -----------------------------------------------------------------------------
-- These instances are defined here to avoid cyclic imports and orphan instances

instance PrintDot ColorScheme where
  unqtDot :: ColorScheme -> DotCode
unqtDot = Bool -> ColorScheme -> DotCode
printColorScheme Bool
True

printColorScheme        :: Bool -> ColorScheme -> DotCode
printColorScheme :: Bool -> ColorScheme -> DotCode
printColorScheme scs :: Bool
scs cs :: ColorScheme
cs = do Bool -> DotCodeM () -> DotCodeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
scs (DotCodeM () -> DotCodeM ()) -> DotCodeM () -> DotCodeM ()
forall a b. (a -> b) -> a -> b
$ ColorScheme -> DotCodeM ()
forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
cs
                             case ColorScheme
cs of
                               X11       -> Text -> DotCode
unqtText "X11"
                               SVG       -> Text -> DotCode
unqtText "svg"
                               Brewer bs :: BrewerScheme
bs -> BrewerScheme -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot BrewerScheme
bs

instance PrintDot BrewerScheme where
  unqtDot :: BrewerScheme -> DotCode
unqtDot (BScheme n :: BrewerName
n l :: Word8
l) = BrewerName -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot BrewerName
n DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> Word8 -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Word8
l

instance PrintDot BrewerName where
  unqtDot :: BrewerName -> DotCode
unqtDot Accent   = Text -> DotCode
unqtText "accent"
  unqtDot Blues    = Text -> DotCode
unqtText "blues"
  unqtDot Brbg     = Text -> DotCode
unqtText "brbg"
  unqtDot Bugn     = Text -> DotCode
unqtText "bugn"
  unqtDot Bupu     = Text -> DotCode
unqtText "bupu"
  unqtDot Dark2    = Text -> DotCode
unqtText "dark2"
  unqtDot Gnbu     = Text -> DotCode
unqtText "gnbu"
  unqtDot Greens   = Text -> DotCode
unqtText "greens"
  unqtDot Greys    = Text -> DotCode
unqtText "greys"
  unqtDot Oranges  = Text -> DotCode
unqtText "oranges"
  unqtDot Orrd     = Text -> DotCode
unqtText "orrd"
  unqtDot Paired   = Text -> DotCode
unqtText "paired"
  unqtDot Pastel1  = Text -> DotCode
unqtText "pastel1"
  unqtDot Pastel2  = Text -> DotCode
unqtText "pastel2"
  unqtDot Piyg     = Text -> DotCode
unqtText "piyg"
  unqtDot Prgn     = Text -> DotCode
unqtText "prgn"
  unqtDot Pubu     = Text -> DotCode
unqtText "pubu"
  unqtDot Pubugn   = Text -> DotCode
unqtText "pubugn"
  unqtDot Puor     = Text -> DotCode
unqtText "puor"
  unqtDot Purd     = Text -> DotCode
unqtText "purd"
  unqtDot Purples  = Text -> DotCode
unqtText "purples"
  unqtDot Rdbu     = Text -> DotCode
unqtText "rdbu"
  unqtDot Rdgy     = Text -> DotCode
unqtText "rdgy"
  unqtDot Rdpu     = Text -> DotCode
unqtText "rdpu"
  unqtDot Rdylbu   = Text -> DotCode
unqtText "rdylbu"
  unqtDot Rdylgn   = Text -> DotCode
unqtText "rdylgn"
  unqtDot Reds     = Text -> DotCode
unqtText "reds"
  unqtDot Set1     = Text -> DotCode
unqtText "set1"
  unqtDot Set2     = Text -> DotCode
unqtText "set2"
  unqtDot Set3     = Text -> DotCode
unqtText "set3"
  unqtDot Spectral = Text -> DotCode
unqtText "spectral"
  unqtDot Ylgn     = Text -> DotCode
unqtText "ylgn"
  unqtDot Ylgnbu   = Text -> DotCode
unqtText "ylgnbu"
  unqtDot Ylorbr   = Text -> DotCode
unqtText "ylorbr"
  unqtDot Ylorrd   = Text -> DotCode
unqtText "ylorrd"