{-# 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           (Word64, Word32, 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 { forall a. DotCodeM a -> State GraphvizState a
getDotCode :: State GraphvizState a }
  deriving ((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
$cfmap :: forall a b. (a -> b) -> DotCodeM a -> DotCodeM b
fmap :: forall a b. (a -> b) -> DotCodeM a -> DotCodeM b
$c<$ :: forall a b. a -> DotCodeM b -> DotCodeM a
<$ :: forall a b. a -> DotCodeM b -> DotCodeM a
Functor, Functor DotCodeM
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
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
$cpure :: forall a. a -> DotCodeM a
pure :: forall a. a -> DotCodeM a
$c<*> :: forall a b. DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
<*> :: forall a b. DotCodeM (a -> b) -> DotCodeM a -> DotCodeM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
liftA2 :: forall a b c.
(a -> b -> c) -> DotCodeM a -> DotCodeM b -> DotCodeM c
$c*> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
*> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
$c<* :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
<* :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM a
Applicative, Applicative DotCodeM
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
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
$c>>= :: forall a b. DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
>>= :: forall a b. DotCodeM a -> (a -> DotCodeM b) -> DotCodeM b
$c>> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
>> :: forall a b. DotCodeM a -> DotCodeM b -> DotCodeM b
$creturn :: forall a. a -> DotCodeM a
return :: forall a. a -> DotCodeM a
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 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 :: forall a. (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 Float
0.4 Int
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 :: forall a. PrintDot a => 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 Word32 where
  unqtDot :: Word32 -> DotCode
unqtDot = Integer -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot (Integer -> DotCode) -> (Word32 -> Integer) -> Word32 -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance PrintDot Word64 where
  unqtDot :: Word64 -> DotCode
unqtDot = Integer -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot (Integer -> DotCode) -> (Word64 -> Integer) -> Word64 -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger

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 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 b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
d

  toDot :: Double -> DotCode
toDot 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
(==) Char
'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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

  listToDot :: [Double] -> DotCode
listToDot [Double
d] = Double -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Double
d
  listToDot [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 Bool
True  = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text Text
"true"
  unqtDot Bool
False = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 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 a. [a] -> 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 Int
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 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 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 Text
""  = DotCode
forall (m :: * -> *). Applicative m => m Doc
empty
unqtString 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 DotCode
b DotCode
a 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 :: forall a b. (PrintDot a, PrintDot b) => a -> b -> DotCode
commaDel a
a 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 :: forall a. PrintDot a => Text -> a -> DotCode
printField Text
f 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 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 String
cs 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 String
cs = ((Char, Char) -> Text -> Text) -> Text -> [(Char, Char)] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = Char
'\\'
    quote :: Char
quote = Char
'"'
    escape :: (Char, Char) -> Text -> Text
escape (Char
c,Char
c') 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
== Char
'\n'                                = Char
slash Char -> Text -> Text
`T.cons` (Char
'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 [Char
'N', Char
'G', Char
'E', Char
'T', Char
'H', Char
'L', Char
'n', Char
'l', Char
'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 Text
""  = []
    withNext 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` Char
' ') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text
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 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 Bool
scs 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
                               ColorScheme
X11       -> Text -> DotCode
unqtText Text
"X11"
                               ColorScheme
SVG       -> Text -> DotCode
unqtText Text
"svg"
                               Brewer BrewerScheme
bs -> BrewerScheme -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot BrewerScheme
bs

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