{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving,
OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.GraphViz.Printing
( module Text.PrettyPrint.Leijen.Text.Monadic
, DotCode
, DotCodeM
, runDotCode
, renderDot
, PrintDot(..)
, unqtText
, dotText
, printIt
, addQuotes
, unqtEscaped
, printEscaped
, wrap
, commaDel
, printField
, angled
, fslash
, printColorScheme
) where
import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util
import Data.GraphViz.Attributes.ColorScheme
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
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
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
class PrintDot a where
unqtDot :: a -> DotCode
toDot :: a -> DotCode
toDot = a -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot
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
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
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
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
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
unqtText :: Text -> DotCode
unqtText :: Text -> DotCode
unqtText = Text -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot
dotText :: Text -> DotCode
dotText :: Text -> DotCode
dotText = Text -> DotCode
forall a. PrintDot a => a -> DotCode
toDot
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
| 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
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
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
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
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
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
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']
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 '/'
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"