module Text.Dot.Render
( graphWithT
, graphT
, graphWith
, graph
, digraphWithT
, digraphT
, digraphWith
, digraph
, strictGraphWithT
, strictGraphT
, strictGraphWith
, strictGraph
, strictDigraphWithT
, strictDigraphT
, strictDigraphWith
, strictDigraph
) where
import "this" Prelude
import Data.HashMap.Strict qualified as M
import Data.List.NonEmpty qualified as NE
import Text.Builder (Builder)
import Text.Builder qualified as TB
import Text.Printf
import Text.Dot.Monad
import Text.Dot.Types
graphWithT :: Monad m => (Entity -> DotT m a) -> m Builder
graphWithT :: forall (m :: * -> *) a.
Monad m =>
(Entity -> DotT m a) -> m Builder
graphWithT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"graph" Builder
"--"
graphT :: Monad m => DotT m a -> m Builder
graphT :: forall (m :: * -> *) a. Monad m => DotT m a -> m Builder
graphT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"graph" Builder
"--" ((Entity -> DotT m a) -> m Builder)
-> (DotT m a -> Entity -> DotT m a) -> DotT m a -> m Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotT m a -> Entity -> DotT m a
forall a b. a -> b -> a
const
graphWith :: (Entity -> Dot a) -> Builder
graphWith :: forall a. (Entity -> Dot a) -> Builder
graphWith = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> ((Entity -> Dot a) -> Identity Builder)
-> (Entity -> Dot a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"graph" Builder
"--"
graph :: Dot a -> Builder
graph :: forall a. Dot a -> Builder
graph = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Dot a -> Identity Builder) -> Dot a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"graph" Builder
"--" ((Entity -> Dot a) -> Identity Builder)
-> (Dot a -> Entity -> Dot a) -> Dot a -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot a -> Entity -> Dot a
forall a b. a -> b -> a
const
digraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder
digraphWithT :: forall (m :: * -> *) a.
Monad m =>
(Entity -> DotT m a) -> m Builder
digraphWithT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"digraph" Builder
"->"
digraphT :: Monad m => DotT m a -> m Builder
digraphT :: forall (m :: * -> *) a. Monad m => DotT m a -> m Builder
digraphT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"digraph" Builder
"->" ((Entity -> DotT m a) -> m Builder)
-> (DotT m a -> Entity -> DotT m a) -> DotT m a -> m Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotT m a -> Entity -> DotT m a
forall a b. a -> b -> a
const
digraphWith :: (Entity -> Dot a) -> Builder
digraphWith :: forall a. (Entity -> Dot a) -> Builder
digraphWith = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> ((Entity -> Dot a) -> Identity Builder)
-> (Entity -> Dot a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"digraph" Builder
"->"
digraph :: Dot a -> Builder
digraph :: forall a. Dot a -> Builder
digraph = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Dot a -> Identity Builder) -> Dot a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"digraph" Builder
"->" ((Entity -> Dot a) -> Identity Builder)
-> (Dot a -> Entity -> Dot a) -> Dot a -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot a -> Entity -> Dot a
forall a b. a -> b -> a
const
strictGraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder
strictGraphWithT :: forall (m :: * -> *) a.
Monad m =>
(Entity -> DotT m a) -> m Builder
strictGraphWithT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict graph" Builder
"--"
strictGraphT :: Monad m => DotT m a -> m Builder
strictGraphT :: forall (m :: * -> *) a. Monad m => DotT m a -> m Builder
strictGraphT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict graph" Builder
"--" ((Entity -> DotT m a) -> m Builder)
-> (DotT m a -> Entity -> DotT m a) -> DotT m a -> m Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotT m a -> Entity -> DotT m a
forall a b. a -> b -> a
const
strictGraphWith :: (Entity -> Dot a) -> Builder
strictGraphWith :: forall a. (Entity -> Dot a) -> Builder
strictGraphWith = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> ((Entity -> Dot a) -> Identity Builder)
-> (Entity -> Dot a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict graph" Builder
"--"
strictGraph :: Dot a -> Builder
strictGraph :: forall a. Dot a -> Builder
strictGraph = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Dot a -> Identity Builder) -> Dot a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict graph" Builder
"--" ((Entity -> Dot a) -> Identity Builder)
-> (Dot a -> Entity -> Dot a) -> Dot a -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot a -> Entity -> Dot a
forall a b. a -> b -> a
const
strictDigraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder
strictDigraphWithT :: forall (m :: * -> *) a.
Monad m =>
(Entity -> DotT m a) -> m Builder
strictDigraphWithT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict digraph" Builder
"->"
strictDigraphT :: Monad m => DotT m a -> m Builder
strictDigraphT :: forall (m :: * -> *) a. Monad m => DotT m a -> m Builder
strictDigraphT = Builder -> Builder -> (Entity -> DotT m a) -> m Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict digraph" Builder
"->" ((Entity -> DotT m a) -> m Builder)
-> (DotT m a -> Entity -> DotT m a) -> DotT m a -> m Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotT m a -> Entity -> DotT m a
forall a b. a -> b -> a
const
strictDigraphWith :: (Entity -> Dot a) -> Builder
strictDigraphWith :: forall a. (Entity -> Dot a) -> Builder
strictDigraphWith = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> ((Entity -> Dot a) -> Identity Builder)
-> (Entity -> Dot a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict digraph" Builder
"->"
strictDigraph :: Dot a -> Builder
strictDigraph :: forall a. Dot a -> Builder
strictDigraph = Identity Builder -> Builder
forall a. Identity a -> a
runIdentity (Identity Builder -> Builder)
-> (Dot a -> Identity Builder) -> Dot a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> (Entity -> Dot a) -> Identity Builder
forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
"strict digraph" Builder
"->" ((Entity -> Dot a) -> Identity Builder)
-> (Dot a -> Entity -> Dot a) -> Dot a -> Identity Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot a -> Entity -> Dot a
forall a b. a -> b -> a
const
render :: Monad m => Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render :: forall (m :: * -> *) a.
Monad m =>
Builder -> Builder -> (Entity -> DotT m a) -> m Builder
render Builder
gtype Builder
arrow Entity -> DotT m a
f = do
let root :: Entity
root = EntityType -> Int -> Entity
Entity EntityType
Subgraph (-Int
1)
DotGraph
allGraph <- Entity -> DotT m a -> m DotGraph
forall (m :: * -> *) a. Monad m => Entity -> DotT m a -> m DotGraph
run Entity
root (Entity -> DotT m a
f Entity
root)
pure $ Builder -> [Builder] -> Builder
forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
"\n" ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ DotGraph -> Builder -> Builder -> Entity -> [Builder]
visit DotGraph
allGraph Builder
gtype Builder
arrow Entity
root
indent :: [Builder] -> [Builder]
indent :: [Builder] -> [Builder]
indent = (Builder -> Builder) -> [Builder] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder
" " <>)
visit :: DotGraph -> Builder -> Builder -> Entity -> [Builder]
visit :: DotGraph -> Builder -> Builder -> Entity -> [Builder]
visit DotGraph {Int
NonEmpty DotContext
HashMap Entity DotContext
HashMap Entity (HashMap Text Text)
HashMap Entity EdgeInfo
HashMap EntityType (HashMap Text Text)
Entity
_defaultAttributes :: HashMap EntityType (HashMap Text Text)
_entityAttributes :: HashMap Entity (HashMap Text Text)
_edgeInfo :: HashMap Entity EdgeInfo
_subgraphInfo :: HashMap Entity DotContext
_contextStack :: NonEmpty DotContext
_entityIndex :: Int
_latest :: Entity
_latest :: DotGraph -> Entity
_entityIndex :: DotGraph -> Int
_contextStack :: DotGraph -> NonEmpty DotContext
_subgraphInfo :: DotGraph -> HashMap Entity DotContext
_edgeInfo :: DotGraph -> HashMap Entity EdgeInfo
_entityAttributes :: DotGraph -> HashMap Entity (HashMap Text Text)
_defaultAttributes :: DotGraph -> HashMap EntityType (HashMap Text Text)
..} Builder
gtype Builder
arrow = Entity -> [Builder]
visitGraph
where
magnitude :: Int
magnitude = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_entityIndex :: Double)) :: Int
intFormat :: String
intFormat = [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
"%0", Int -> String
forall a. Show a => a -> String
show Int
magnitude, String
"d"]
renderIndex :: Entity -> Builder
renderIndex (Entity EntityType
t Int
i) =
let prefix :: Builder
prefix = case EntityType
t of
EntityType
Subgraph -> Builder
"subgraph"
EntityType
Cluster -> Builder
"cluster"
EntityType
Node -> Builder
"node"
EntityType
Edge -> String -> Builder
forall a. HasCallStack => String -> a
error String
"Text.Dot.Render.visit: tried to render an edge id"
suffix :: Builder
suffix = String -> Builder
TB.string (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
intFormat Int
i
in Builder
prefix Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
suffix
visitAttribute :: (Text, Text) -> Builder
visitAttribute (Text
name, Text
value) =
[Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Text -> Builder
TB.text Text
name, Builder
"=\"", Text -> Builder
TB.text Text
value, Builder
"\""]
visitAttributes :: HashMap Text Text -> [Builder]
visitAttributes =
((Text, Text) -> Builder) -> [(Text, Text)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Builder
visitAttribute ([(Text, Text)] -> [Builder])
-> (HashMap Text Text -> [(Text, Text)])
-> HashMap Text Text
-> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
M.toList
visitEntity :: Entity -> [Builder]
visitEntity Entity
e =
let attrs :: HashMap Text Text
attrs = HashMap Text Text -> Maybe (HashMap Text Text) -> HashMap Text Text
forall a. a -> Maybe a -> a
fromMaybe HashMap Text Text
forall a. Monoid a => a
mempty (Maybe (HashMap Text Text) -> HashMap Text Text)
-> Maybe (HashMap Text Text) -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ Entity
-> HashMap Entity (HashMap Text Text) -> Maybe (HashMap Text Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Entity
e HashMap Entity (HashMap Text Text)
_entityAttributes
in [Builder] -> [Builder]
indent ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ case Entity -> EntityType
getType Entity
e of
EntityType
Node -> Entity -> HashMap Text Text -> [Builder]
visitNode Entity
e HashMap Text Text
attrs
EntityType
Edge -> Entity -> HashMap Text Text -> EdgeInfo -> [Builder]
visitEdge Entity
e HashMap Text Text
attrs (HashMap Entity EdgeInfo
_edgeInfo HashMap Entity EdgeInfo -> Entity -> EdgeInfo
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! Entity
e)
EntityType
Cluster -> Entity -> HashMap Text Text -> DotContext -> [Builder]
visitSubgraph Entity
e HashMap Text Text
attrs (HashMap Entity DotContext
_subgraphInfo HashMap Entity DotContext -> Entity -> DotContext
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! Entity
e)
EntityType
Subgraph -> Entity -> HashMap Text Text -> DotContext -> [Builder]
visitSubgraph Entity
e HashMap Text Text
attrs (HashMap Entity DotContext
_subgraphInfo HashMap Entity DotContext -> Entity -> DotContext
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! Entity
e)
visitEntities :: DotContext -> [Builder]
visitEntities =
(Entity -> [Builder]) -> DotContext -> [Builder]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Entity -> [Builder]
visitEntity (DotContext -> [Builder])
-> (DotContext -> DotContext) -> DotContext -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotContext -> DotContext
forall a. [a] -> [a]
reverse
visitNode :: Entity -> HashMap Text Text -> [Builder]
visitNode Entity
e HashMap Text Text
attrs =
Builder -> [Builder]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> [Builder]) -> Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Entity -> Builder
renderIndex Entity
e
, Builder
" ["
, Builder -> [Builder] -> Builder
forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
"," ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [Builder]
visitAttributes HashMap Text Text
attrs
, Builder
"]"
]
visitEdge :: Entity -> HashMap Text Text -> EdgeInfo -> [Builder]
visitEdge Entity
_ HashMap Text Text
attrs (EdgeInfo Entity
o1 Entity
o2 Entity
p1 Entity
p2) =
Builder -> [Builder]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> [Builder]) -> Builder -> [Builder]
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ Entity -> Builder
renderIndex Entity
p1
, Builder
" "
, Builder
arrow
, Builder
" "
, Entity -> Builder
renderIndex Entity
p2
, Builder
" ["
, Builder -> [Builder] -> Builder
forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TB.intercalate Builder
"," ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [Builder]
visitAttributes (HashMap Text Text -> [Builder]) -> HashMap Text Text -> [Builder]
forall a b. (a -> b) -> a -> b
$ HashMap Text Text
attrs
HashMap Text Text -> HashMap Text Text -> HashMap Text Text
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text
"ltail", Builder -> Text
TB.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Entity -> Builder
renderIndex Entity
o1) | Entity -> EntityType
getType Entity
o1 EntityType -> EntityType -> Bool
forall a. Eq a => a -> a -> Bool
== EntityType
Cluster]
HashMap Text Text -> HashMap Text Text -> HashMap Text Text
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text
"lhead", Builder -> Text
TB.run (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Entity -> Builder
renderIndex Entity
o2) | Entity -> EntityType
getType Entity
o2 EntityType -> EntityType -> Bool
forall a. Eq a => a -> a -> Bool
== EntityType
Cluster]
, Builder
"]"
]
visitGraph :: Entity -> [Builder]
visitGraph Entity
e =
Builder -> Entity -> HashMap Text Text -> DotContext -> [Builder]
visitInner Builder
gtype Entity
e (HashMap Text Text -> Maybe (HashMap Text Text) -> HashMap Text Text
forall a. a -> Maybe a -> a
fromMaybe HashMap Text Text
forall a. Monoid a => a
mempty (Maybe (HashMap Text Text) -> HashMap Text Text)
-> Maybe (HashMap Text Text) -> HashMap Text Text
forall a b. (a -> b) -> a -> b
$ Entity
-> HashMap Entity (HashMap Text Text) -> Maybe (HashMap Text Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Entity
e HashMap Entity (HashMap Text Text)
_entityAttributes) (NonEmpty DotContext -> DotContext
forall a. NonEmpty a -> a
NE.head NonEmpty DotContext
_contextStack)
visitSubgraph :: Entity -> HashMap Text Text -> DotContext -> [Builder]
visitSubgraph Entity
e =
Builder -> Entity -> HashMap Text Text -> DotContext -> [Builder]
visitInner (Builder
"subgraph " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Entity -> Builder
renderIndex Entity
e) Entity
e
visitInner :: Builder -> Entity -> HashMap Text Text -> DotContext -> [Builder]
visitInner Builder
etype Entity
_ HashMap Text Text
attrs DotContext
entities = [[Builder]] -> [Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Builder
etype Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" {"]
, [Builder] -> [Builder]
indent ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Builder -> Builder) -> [Builder] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
";") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [Builder]
visitAttributes HashMap Text Text
attrs
, DotContext -> [Builder]
visitEntities DotContext
entities
, [Builder
"}"]
]