module Text.Dot.Gen (
module Text.Dot.Gen
, Dot
, DotGraph
, NodeId
, Attribute
, DecType
, RankdirType
) where
import Control.Monad.State (StateT, execStateT, get, modify)
import Control.Monad.Writer (WriterT, execWriterT, tell)
import Text.Dot.Types.Internal
import Control.Monad (void)
import Data.Monoid (Monoid (..), (<>))
import Data.Text (Text)
import qualified Data.Text as T
type DotGen = StateT State (WriterT Dot Identity)
type State = Int
graph :: GraphType
-> GraphName
-> DotGen a
-> DotGraph
graph gt gn func = Graph gt gn $ genDot func
graph_ :: GraphType
-> DotGen a
-> DotGraph
graph_ gt func = graph gt "haphviz" func
genDot :: DotGen a -> Dot
genDot = genSubDot 0
genSubDot :: Int -> DotGen a -> Dot
genSubDot n func = runIdentity $ execWriterT $ execStateT func n
directed :: GraphType
directed = DirectedGraph
undirected :: GraphType
undirected = UndirectedGraph
genNode :: NodeId -> [Attribute] -> DotGen ()
genNode ni ats = tell $ Node ni ats
namedNode :: Text
-> [Attribute] -> DotGen NodeId
namedNode t ats = do
let ni = UserId t
genNode ni ats
return ni
namelessNode :: [Attribute] -> DotGen NodeId
namelessNode ats = do
ni <- newNode
genNode ni ats
return ni
node :: Text
-> DotGen NodeId
node l = namelessNode [label =: l]
node_ :: NodeId
-> Text
-> DotGen ()
node_ ni l = genNode ni [label =: l]
newNode :: DotGen NodeId
newNode = do
i <- get
modify (+1)
return $ Nameless i
genEdge :: NodeId -> NodeId -> [Attribute] -> DotGen ()
genEdge n1 n2 ats = tell $ Edge n1 n2 ats
(-->) :: NodeId -> NodeId -> DotGen ()
n1 --> n2 = genEdge n1 n2 []
(=:) :: AttributeName -> AttributeValue -> Attribute
(=:) = (,)
label :: AttributeName
label = "label"
compound :: AttributeName
compound = "compound"
shape :: AttributeName
shape = "shape"
color :: AttributeName
color = "color"
dir :: AttributeName
dir = "dir"
width :: AttributeName
width = "width"
height :: AttributeName
height = "height"
true :: AttributeValue
true = "true"
false :: AttributeValue
false = "false"
none :: AttributeValue
none = "none"
genDec :: DecType -> [Attribute] -> DotGen ()
genDec t ats = tell $ Declaration t ats
graphDec :: [Attribute] -> DotGen ()
graphDec = genDec DecGraph
nodeDec :: [Attribute] -> DotGen ()
nodeDec = genDec DecNode
edgeDec :: [Attribute] -> DotGen ()
edgeDec = genDec DecEdge
subgraph :: Text -> DotGen () -> DotGen GraphName
subgraph name content = do
n <- get
let c = genSubDot n content
tell $ Subgraph name c
return name
cluster :: Text -> DotGen () -> DotGen GraphName
cluster name = subgraph $ "cluster_" <> name
cluster_ :: Text -> DotGen () -> DotGen ()
cluster_ name subgraph = void $ cluster name subgraph
rankdir :: RankdirType -> DotGen ()
rankdir = tell . Rankdir
leftRight :: RankdirType
leftRight = LR
topBottom :: RankdirType
topBottom = TB
labelDec :: Text -> DotGen ()
labelDec = tell . Label
(.:) :: NodeId
-> Text
-> NodeId
(UserId t) .: p = UserId $ t <> ":" <> p
(Nameless i) .: p = UserId $ T.pack (show i) <> ":" <> p