diff --git a/README.md b/README.md
index c85e0bc..b97a321 100644
--- a/README.md
+++ b/README.md
@@ -6,31 +6,45 @@ documentation can be found on [pursuit](https://pursuit.purescript.org/packages/
define your model like this:
```purescript
-DiGraph [
- node "a" [ Shape Diamond, Style Filled, Node.FillColor red ],
- node "b" [],
- "a" ==> "b",
- "a" =*> "d" $ [ Edge.FillColor red ],
- Subgraph [
- node "d" []
+import Data.DotLang.Attr.Global as Global
+import Data.DotLang.Attr.Node
+import Data.DotLang.Attr.Edge
+import Data.DotLang.Attr
+import Data.DotLang.Class (toText)
+import Color.Scheme.MaterialDesign (red)
+
+
+graph = DiGraph
+ [ global [ rankDir FromLeft ]
+ , node "a" [ shape Node.Diamond, style Filled, fillColor red ]
+ , node "b" []
+ , "a" ==> "b"
+ , "a" =*> "d" $ [ fillColor red ]
+ , Subgraph
+ [ node "d" []
+ ]
]
-]
```
can be rendered using `toText` to:
```
digraph {
- a [shape=diamond, style=filled, fillcolor="#f44336"];
- b [];
- a -> b;
- a -> d [fillcolor="#f44336"];
- subgraph {
+ rankdir=LR;
+ a [fillcolor="#f44336", shape=diamond, style=filled];
+ b [];
+ a -> b;
+ a -> d [fillcolor="#f44336"];
+ subgraph {
d [];
}
}
```
+Which looks like this, when rendered with graphviz:
+
+
+
### Installation
#### Spago
@@ -68,6 +82,18 @@ bower i purescript-dotlang
Changelog
=========
+v4.0.0
+------
+
+Breaking Changes:
+
+- dotlang now internally represents attributes as a record. To **migrate**:
+ - replace calls to Attribute constructors with their lower-case counter-part:
+ E.g. `FontColor` with calls to `fontColor`
+ - replace calls to `Node`, `Edge` and `Global` with `node`, `edge` and `global`
+- to avoid name collisions, `Edge.Diamond :: ArrowHead` was renamed to `Edge.FDiamond`
+
+
v3.0.0
------
diff --git a/example.svg b/example.svg
new file mode 100644
index 0000000..f6ace02
--- /dev/null
+++ b/example.svg
@@ -0,0 +1,41 @@
+
+
+
+
+
\ No newline at end of file
diff --git a/spago.dhall b/spago.dhall
index 141c059..84fd7b6 100644
--- a/spago.dhall
+++ b/spago.dhall
@@ -1,21 +1,17 @@
-{ name =
- "dotlang"
-, license =
- "MIT"
-, repository =
- "https://github.com/csicar/purescript-dotlang.git"
+{ name = "dotlang"
+, license = "MIT"
+, repository = "https://github.com/csicar/purescript-dotlang.git"
, dependencies =
- [ "colors"
- , "console"
- , "effect"
- , "generics-rep"
- , "prelude"
- , "psci-support"
- , "strings"
- , "test-unit"
- ]
-, packages =
- ./packages.dhall
-, sources =
- [ "src/**/*.purs", "test/**/*.purs" ]
+ [ "colors"
+ , "console"
+ , "effect"
+ , "generics-rep"
+ , "heterogeneous"
+ , "prelude"
+ , "psci-support"
+ , "strings"
+ , "test-unit"
+ ]
+, packages = ./packages.dhall
+, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}
diff --git a/src/Data/DotLang.purs b/src/Data/DotLang.purs
index dc6c7e7..e0f084b 100644
--- a/src/Data/DotLang.purs
+++ b/src/Data/DotLang.purs
@@ -1,39 +1,47 @@
module Data.DotLang where
+import Prelude
+
+import Color (Color, toHexString)
+import Data.Array (foldr, null)
+import Data.DotLang.Attr (Attribute, attributesToText)
+import Data.DotLang.Attr.Common (label)
+import Data.DotLang.Attr.Common as Gloabl
import Data.DotLang.Attr.Edge as Edge
-import Data.DotLang.Attr.Node as Node
import Data.DotLang.Attr.Global as Global
+import Data.DotLang.Attr.Node as Node
import Data.DotLang.Class (class DotLang, toText)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.String (joinWith)
-import Data.Array (null)
+import Data.Symbol (SProxy(..))
import Prelude (class Show, ($), (<$>), (<>))
-- | type alias for a Nodes Name
-type Id = String
+type Id
+ = String
-- | Dot-Node
-- | example :
-- | ```purescript
--- | Node "e" [Margin 3, Label "some label"]
+-- | node "e" [margin 3, label "some label"]
-- | ```
-- | is turned into: `e [margin=3, label="some label"];`
-data Node = Node Id (Array Node.Attr)
-
+data Node
+ = Node Id { | Node.Attributes }
-- | get a nodes id
-- | example:
-- | ```purescript
--- | nodeId (Node "e" [Label "foo"]) == "e"
+-- | nodeId (node "e" [label "foo"]) == "e"
-- | ```
nodeId :: Node -> Id
nodeId (Node id _) = id
-- | change Nodes id to a new one; keeing the old id as the label
--- | example: `mapNodeId (\a -> a+"!") (Node "e" []) == Node "e!" [Label "e"]`
+-- | example: `mapNodeId (\a -> a+"!") (node "e" []) == node "e!" [label "e"]`
changeNodeId :: (Id -> Id) -> Node -> Node
-changeNodeId f (Node id attr) = Node (f id) $ attr <> [Node.label id]
+changeNodeId f (Node id attr) = Node (f id) $ (label id attr)
derive instance genericNode :: Generic Node _
@@ -41,8 +49,7 @@ instance showNode :: Show Node where
show = genericShow
instance nodeDotLang :: DotLang Node where
- toText (Node id attrs) = id <> " [" <> joinWith ", " (toText <$> attrs) <> "]"
-
+ toText (Node id attrs) = id <> " [" <> joinWith ", " (attributesToText attrs) <> "]"
data EdgeType
= Forward
@@ -51,7 +58,8 @@ data EdgeType
derive instance genericEdgeType :: Generic EdgeType _
-instance showEdgeType :: Show EdgeType where show = genericShow
+instance showEdgeType :: Show EdgeType where
+ show = genericShow
instance dotLangEdgeType :: DotLang EdgeType where
toText Forward = "->"
@@ -59,9 +67,10 @@ instance dotLangEdgeType :: DotLang EdgeType where
toText NoDir = "--"
-- | egde from id to id
--- | `toText $ Edge Forward "a" "b" []` == `a -> b []`
+-- | `toText $ edge Forward "a" "b" []` == `a -> b []`
-- | EdgeType determines the direction of the arrow
-data Edge = Edge EdgeType Id Id (Array Edge.Attr)
+data Edge
+ = Edge EdgeType Id Id { | Edge.Attributes }
derive instance genericEdge :: Generic Edge _
@@ -71,30 +80,37 @@ instance showEdge :: Show Edge where
instance dotLangEdge :: DotLang Edge where
toText (Edge e id id2 attrs) = id <> " " <> (toText e) <> " " <> id2 <> attrText
where
- attrText = if null attrs then "" else " [" <> joinWith ", " (toText <$> attrs) <> "]"
+ attrText = case attributesToText attrs of
+ [] -> ""
+ textAttributes -> " [" <> joinWith ", " textAttributes <> "]"
-- | definition in a graph
data Definition
- = Global (Array Global.Attr)
+ = Global { | Global.Attributes }
| NodeDef Node
| EdgeDef Edge
| Subgraph (Array Definition)
+derive instance genericDefinition :: Generic Definition _
+
+instance showDefinition :: Show Definition where
+ show a = genericShow a
+
-- |
-- | ```purescript
--- | global [ Global.RankDir Global.FromLeft ] -- ∷ Definition
+-- | global [ Global.rankDir Global.FromLeft ] -- ∷ Definition
-- | ```
-- | global as a part of a definition
-global :: Array Global.Attr -> Definition
-global = Global
+global :: Array (Attribute { | Global.Attributes }) -> Definition
+global = (foldr ($) Global.defaultAttributes) >>> Global
-- |
-- | ```purescript
-- | node "a" [] -- ∷ Definition
-- | ```
-- | node as a part of a definition
-node :: Id → Array Node.Attr → Definition
-node id attrs = NodeDef $ Node id attrs
+node :: Id → Array (Attribute { | Node.Attributes }) → Definition
+node id attrs = NodeDef $ Node id (foldr ($) Node.defaultAttributes $ attrs)
-- |
-- | ```purescript
@@ -102,22 +118,22 @@ node id attrs = NodeDef $ Node id attrs
-- | ```
-- | edge as a part of a definition.
-- | `==>` and `=*>` can also be used for that purpose.
-edge :: EdgeType → Id → Id → Array Edge.Attr → Definition
-edge t id id2 attrs = EdgeDef $ Edge t id id2 attrs
+edge :: EdgeType → Id → Id → Array (Attribute { | Edge.Attributes }) → Definition
+edge t id id2 attrs = EdgeDef $ Edge t id id2 (foldr ($) Edge.defaultAttributes $ attrs)
-forwardEdgeWithAttrs ∷ Id → Id → Array Edge.Attr → Definition
+forwardEdgeWithAttrs ∷ Id → Id → Array (Attribute { | Edge.Attributes }) → Definition
forwardEdgeWithAttrs = edge Forward
forwardEdge :: Id → Id → Definition
forwardEdge l r = forwardEdgeWithAttrs l r []
-backwardEdgeWithAttrs ∷ Id → Id → Array Edge.Attr → Definition
+backwardEdgeWithAttrs ∷ Id → Id → Array (Attribute { | Edge.Attributes }) → Definition
backwardEdgeWithAttrs = edge Backward
backwardEdge ∷ Id → Id → Definition
backwardEdge l r = backwardEdgeWithAttrs l r []
-normalEdgeWithAttrs ∷ Id → Id → Array Edge.Attr → Definition
+normalEdgeWithAttrs ∷ Id → Id → Array (Attribute { | Edge.Attributes }) → Definition
normalEdgeWithAttrs = edge NoDir
normalEdge ∷ Id → Id → Definition
@@ -129,40 +145,45 @@ normalEdge l r = normalEdgeWithAttrs l r []
-- | ```
-- | Forward edge as as a definition
infix 5 forwardEdge as ==>
+
-- |
-- | ```purescript
--- | "a" =*> "b" $ [ Edge.FillColor red ]
+-- | "a" =*> "b" $ [ fillColor red ]
-- | -- toText will be: a -> b [fillcolor="#f44336"];
-- | ```
-- | Forward edge with attributes as a definition
infix 5 forwardEdgeWithAttrs as =*>
+
-- |
-- | ```purescript
-- | "a" <== "b" -- :: Definition
-- | ```
-- | Backward edge as a definition
infix 5 backwardEdge as <==
+
-- |
-- | ```purescript
--- | "a" <*= "b" $ [ Edge.FillColor red ]
+-- | "a" <*= "b" $ [ fillColor red ]
-- | ```
-- | Backward edge with attributes as a definition
infix 5 backwardEdgeWithAttrs as <*=
+
-- |
-- | ```purescript
-- | "a" -==- "b"
-- | ```
-- | Normal edge as definition
infix 5 normalEdge as -==-
+
-- |
-- | ```purescript
--- | "a" =*= "b" $ [ Edge.FillColor red ]
+-- | "a" =*= "b" $ [ fillColor red ]
-- | ```
-- | Normal edge with attibutes
infix 5 normalEdgeWithAttrs as =*=
instance definitionDotlang :: DotLang Definition where
- toText (Global attrs) = joinWith "; " (toText <$> attrs) <> "; "
+ toText (Global attrs) = joinWith "; " (attributesToText attrs) <> "; "
toText (NodeDef n) = toText n <> "; "
toText (EdgeDef e) = toText e <> "; "
toText (Subgraph defs) = "subgraph { " <> (joinWith "" $ toText <$> defs) <> "}"
@@ -172,6 +193,10 @@ data Graph
= Graph (Array Definition)
| DiGraph (Array Definition)
+derive instance genericGraph :: Generic Graph _
+
+instance showGraph :: Show Graph where
+ show = genericShow
instance graphDotLang :: DotLang Graph where
toText (Graph defs) = "graph {" <> (joinWith "" $ toText <$> defs) <> "}"
@@ -185,5 +210,3 @@ graphFromElements n e = DiGraph $ (NodeDef <$> n) <> (EdgeDef <$> e)
-- | `a` is a type that can be represented by a Dot-Graph
class GraphRepr a where
toGraph :: a -> Graph
-
-
diff --git a/src/Data/DotLang/Attr.purs b/src/Data/DotLang/Attr.purs
index a8ba0d9..e3364e2 100644
--- a/src/Data/DotLang/Attr.purs
+++ b/src/Data/DotLang/Attr.purs
@@ -1,23 +1,30 @@
-module Data.DotLang.Attr where
+module Data.DotLang.Attr (Attribute, attributesToText, FoldToDotLang()) where
import Prelude
-import Data.DotLang.Class (class DotLang)
-import Data.Generic.Rep (class Generic)
-import Data.Generic.Rep.Show (genericShow)
+import Data.DotLang.Class (class DotLangValue, toValue)
+import Data.Maybe (Maybe(..))
+import Data.Symbol (class IsSymbol, SProxy, reflectSymbol)
+import Heterogeneous.Folding (class FoldingWithIndex, class HFoldlWithIndex, hfoldlWithIndex)
+import Prim.RowList (class RowToList)
-data FillStyle
- = Filled
- | Dotted
- | Invis
-derive instance genericFillStyle :: Generic FillStyle _
+type Attribute r
+ = r -> r
-instance showFillStyle :: Show FillStyle where
- show = genericShow
+data FoldToDotLang
+ = FoldToDotLang
-instance fillStyleDotLang :: DotLang FillStyle where
- toText Filled = "filled"
- toText Dotted = "dotted"
- toText Invis = "invis"
+instance foldAttribtues ∷
+ (IsSymbol sym, DotLangValue a) =>
+ FoldingWithIndex FoldToDotLang (SProxy sym) (Array String) (Maybe a) (Array String) where
+ foldingWithIndex _ _ acc Nothing = acc
+ foldingWithIndex _ key acc (Just value) = acc <> [ reflectSymbol key <> "=" <> toValue value ]
+attributesToText ::
+ ∀ r rl.
+ RowToList r rl =>
+ HFoldlWithIndex FoldToDotLang (Array String) { | r } (Array String) =>
+ { | r } ->
+ (Array String)
+attributesToText r = hfoldlWithIndex FoldToDotLang ([] :: Array String) r
diff --git a/src/Data/DotLang/Attr/Common.purs b/src/Data/DotLang/Attr/Common.purs
new file mode 100644
index 0000000..4d3b5e7
--- /dev/null
+++ b/src/Data/DotLang/Attr/Common.purs
@@ -0,0 +1,104 @@
+module Data.DotLang.Attr.Common where
+
+import Prelude
+
+import Color (Color)
+import Data.DotLang.Attr (Attribute)
+import Data.DotLang.Class (class DotLangValue)
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Eq (genericEq)
+import Data.Generic.Rep.Show (genericShow)
+import Data.Maybe (Maybe(..))
+
+type Attributes r
+ = ( color :: Maybe Color
+ , fontcolor :: Maybe Color
+ , fontsize :: Maybe Int
+ , label :: Maybe LabelValue
+ , style :: Maybe FillStyle
+ , fillcolor :: Maybe Color
+ , penWidth :: Maybe Number
+ | r
+ )
+
+defaultAttributes :: { | Attributes () }
+defaultAttributes =
+ { color: Nothing
+ , fontcolor: Nothing
+ , fontsize: Nothing
+ , label: Nothing
+ , style: Nothing
+ , fillcolor: Nothing
+ , penWidth: Nothing
+ }
+
+
+color :: ∀ r. Color -> Attribute { | Attributes r }
+color v = _ { color = Just v }
+
+
+fontColor :: ∀ r. Color -> Attribute { | Attributes r }
+fontColor v = _ { fontcolor = Just v }
+
+
+fontSize :: ∀ r. Int -> Attribute { | Attributes r }
+fontSize v = _ { fontsize = Just v }
+
+
+style :: ∀ r. FillStyle -> Attribute { | Attributes r }
+style v = _ { style = Just v }
+
+fillColor :: ∀ r. Color -> Attribute { | Attributes r }
+fillColor v = _ { fillcolor = Just v }
+
+
+penWidth :: ∀ r. Number -> Attribute { | Attributes r }
+penWidth v = _ { penWidth = Just v }
+
+
+-- |
+-- | ```purescript
+-- | htmlLabel "" -- :: Attribute ..
+-- | ```
+-- | htmlLabel as a part of an attribute of a node.
+htmlLabel :: ∀ r. String -> Attribute { | Attributes r }
+htmlLabel text = _ { label = Just $ HtmlLabel text }
+
+-- |
+-- | ```purescript
+-- | textLabel "..." -- :: Attribute ...
+-- | ```
+-- | label as a part of an attribute of a node.
+label :: ∀ r. String -> Attribute { | Attributes r }
+label text = _ { label = Just $ TextLabel text }
+
+data FillStyle
+ = Filled
+ | Dotted
+ | Invis
+
+derive instance genericFillStyle :: Generic FillStyle _
+instance eqFillStyle :: Eq FillStyle where eq = genericEq
+
+instance showFillStyle :: Show FillStyle where
+ show = genericShow
+
+instance fillstyle :: DotLangValue FillStyle where
+ toValue Filled = "filled"
+ toValue Dotted = "dotted"
+ toValue Invis = "invis"
+
+
+data LabelValue
+ = TextLabel String
+ | HtmlLabel String
+
+derive instance genericLabel :: Generic LabelValue _
+
+instance showLabel :: Show LabelValue where
+ show = genericShow
+
+instance labelValue :: DotLangValue LabelValue where
+ toValue (TextLabel t) = show t
+ toValue (HtmlLabel t) = show t
+
diff --git a/src/Data/DotLang/Attr/Edge.purs b/src/Data/DotLang/Attr/Edge.purs
index 4bfc7ee..fc99974 100644
--- a/src/Data/DotLang/Attr/Edge.purs
+++ b/src/Data/DotLang/Attr/Edge.purs
@@ -1,22 +1,15 @@
module Data.DotLang.Attr.Edge where
import Prelude
-
-import Color (Color, toHexString)
-import Data.DotLang.Attr (FillStyle)
-import Data.DotLang.Class (class DotLang, toText)
+import Data.DotLang.Attr (Attribute)
+import Data.DotLang.Attr.Common as Common
+import Data.DotLang.Class (class DotLangValue)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
+import Data.Maybe (Maybe(..))
+import Record as Record
-data LabelValue
- = TextLabel String
- | HtmlLabel String
-
-derive instance genericLabel :: Generic LabelValue _
-
-instance showLabel :: Show LabelValue where
- show = genericShow
-
+--| https://www.graphviz.org/doc/info/attrs.html#k:arrowType
data ArrowHeadStyle
= Normal
| Inv
@@ -28,7 +21,7 @@ data ArrowHeadStyle
| Tee
| Empty
| InvEmpty
- | Diamond
+ | FDiamond
| ODiamond
| EDiamond
| Crow
@@ -43,65 +36,38 @@ derive instance genericArrowHeadStyle :: Generic ArrowHeadStyle _
instance showArrowHeadStyle :: Show ArrowHeadStyle where
show = genericShow
-instance arrowHeadStyle :: DotLang ArrowHeadStyle where
- toText Normal = "normal"
- toText Inv = "inv"
- toText Dot = "dot"
- toText InvDot = "invdot"
- toText ODot = "odot"
- toText InvODot = "invodot"
- toText None = "none"
- toText Tee = "tee"
- toText Empty = "empty"
- toText InvEmpty = "invempty"
- toText Diamond = "diamond"
- toText ODiamond = "odiamond"
- toText EDiamond = "ediamond"
- toText Crow = "crow"
- toText Box = "box"
- toText OBox = "obox"
- toText Open = "open"
- toText HalfOpen = "halfopen"
- toText Vee = "vee"
-
-data Attr
- = Color Color
- | FontColor Color
- | FontSize Int
- | Label LabelValue
- | Style FillStyle
- | FillColor Color
- | PenWidth Number
- | ArrowHead ArrowHeadStyle
-
-derive instance genericAttr :: Generic Attr _
-
-instance showAttr :: Show Attr where
- show = genericShow
+instance arrowHeadStyleValue :: DotLangValue ArrowHeadStyle where
+ toValue Normal = "normal"
+ toValue Inv = "inv"
+ toValue Dot = "dot"
+ toValue InvDot = "invdot"
+ toValue ODot = "odot"
+ toValue InvODot = "invodot"
+ toValue None = "none"
+ toValue Tee = "tee"
+ toValue Empty = "empty"
+ toValue InvEmpty = "invempty"
+ toValue FDiamond = "diamond"
+ toValue ODiamond = "odiamond"
+ toValue EDiamond = "ediamond"
+ toValue Crow = "crow"
+ toValue Box = "box"
+ toValue OBox = "obox"
+ toValue Open = "open"
+ toValue HalfOpen = "halfopen"
+ toValue Vee = "vee"
-instance attrDotLang :: DotLang Attr where
- toText (Color s) = "color=\"" <> toHexString s <> "\""
- toText (FontColor s) = "fontcolor=\"" <> toHexString s <> "\""
- toText (FontSize i) = "fontsize="<> show i
- toText (Style f) = "style="<> toText f
- toText (Label (TextLabel t)) = "label=" <> show t
- toText (Label (HtmlLabel t)) = "label=" <> t
- toText (FillColor c) = "fillcolor=\"" <> toHexString c <> "\""
- toText (PenWidth i) = "penwidth="<> show i
- toText (ArrowHead s) = "arrowhead=" <> toText s
+arrowHead :: ∀ r. ArrowHeadStyle -> Attribute { arrowhead :: Maybe ArrowHeadStyle | r }
+arrowHead v = _ { arrowhead = Just v }
--- |
--- | ```purescript
--- | htmlLabel "" -- :: Attr
--- | ```
--- | htmlLabel as a part of an attribute of an edge.
-htmlLabel :: String -> Attr
-htmlLabel = HtmlLabel >>> Label
+type Attributes
+ = Common.Attributes
+ ( arrowhead :: Maybe ArrowHeadStyle
+ )
--- |
--- | ```purescript
--- | label "..." -- :: Attr
--- | ```
--- | label as a part of an attribute of an edge.
-label :: String -> Attr
-label = TextLabel >>> Label
+defaultAttributes :: Record Attributes
+defaultAttributes =
+ Common.defaultAttributes
+ `Record.disjointUnion`
+ { arrowhead: Nothing
+ }
diff --git a/src/Data/DotLang/Attr/Global.purs b/src/Data/DotLang/Attr/Global.purs
index 0db342d..2a4a536 100644
--- a/src/Data/DotLang/Attr/Global.purs
+++ b/src/Data/DotLang/Attr/Global.purs
@@ -1,10 +1,25 @@
module Data.DotLang.Attr.Global where
import Prelude
-
-import Data.DotLang.Class (class DotLang, toText)
+import Data.DotLang.Attr (Attribute, attributesToText)
+import Data.DotLang.Class (class DotLangValue, toValue)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
+import Data.Maybe (Maybe(..))
+
+type Attributes
+ = ( rankdir :: Maybe RankDirValue
+ , pagedir :: Maybe PageDirValue
+ )
+
+defaultAttributes :: { | Attributes }
+defaultAttributes = { rankdir: Nothing, pagedir: Nothing }
+
+rankDir :: RankDirValue -> Attribute { | Attributes }
+rankDir v = _ { rankdir = Just v }
+
+pageDir :: PageDirValue -> Attribute { | Attributes }
+pageDir v = _ { pagedir = Just v }
data RankDirValue
= FromTop
@@ -17,40 +32,35 @@ derive instance genericRankDirVal :: Generic RankDirValue _
instance showRankDirValue :: Show RankDirValue where
show = genericShow
-instance rankDirValueDotLang :: DotLang RankDirValue where
- toText FromTop = "TB"
- toText FromLeft = "LR"
- toText FromBottom = "BT"
- toText FromRight = "RL"
+instance rankDirValueDotLangValue :: DotLangValue RankDirValue where
+ toValue FromTop = "TB"
+ toValue FromLeft = "LR"
+ toValue FromBottom = "BT"
+ toValue FromRight = "RL"
-- | Upper-case first character is major order;
-- | lower-case second character is minor order.
-data PageDirValue = Bl | Br | Tl | Tr | Rb | Rt | Lb | Lt
+data PageDirValue
+ = Bl
+ | Br
+ | Tl
+ | Tr
+ | Rb
+ | Rt
+ | Lb
+ | Lt
derive instance genericPageDirValue :: Generic PageDirValue _
instance showPageDirValue :: Show PageDirValue where
show = genericShow
-instance pageDirValueDotLang :: DotLang PageDirValue where
- toText Bl = "BL"
- toText Br = "BR"
- toText Tl = "TL"
- toText Tr = "TR"
- toText Rb = "RB"
- toText Rt = "RT"
- toText Lb = "LB"
- toText Lt = "LT"
-
-data Attr
- = RankDir RankDirValue
- | PageDir PageDirValue
-
-derive instance genericAttr :: Generic Attr _
-
-instance showAttr :: Show Attr where
- show = genericShow
-
-instance attrDotLang :: DotLang Attr where
- toText (RankDir dir) = "rankdir=" <> toText dir
- toText (PageDir dir) = "pagedir=" <> toText dir
+instance pageDirValueDotLangValue :: DotLangValue PageDirValue where
+ toValue Bl = "BL"
+ toValue Br = "BR"
+ toValue Tl = "TL"
+ toValue Tr = "TR"
+ toValue Rb = "RB"
+ toValue Rt = "RT"
+ toValue Lb = "LB"
+ toValue Lt = "LT"
diff --git a/src/Data/DotLang/Attr/Node.purs b/src/Data/DotLang/Attr/Node.purs
index 1bd7df8..ed81a58 100644
--- a/src/Data/DotLang/Attr/Node.purs
+++ b/src/Data/DotLang/Attr/Node.purs
@@ -1,143 +1,164 @@
-module Data.DotLang.Attr.Node where
+module Data.DotLang.Attr.Node (module Export, shape, ShapeType(..), margin, width, Attributes, defaultAttributes) where
-import Prelude
-
-import Color (Color, toHexString)
-import Data.DotLang.Attr (FillStyle)
-import Data.DotLang.Class (class DotLang, toText)
+import Prelude (class Show)
+import Data.DotLang.Attr (Attribute)
+import Data.DotLang.Attr.Common (FillStyle(..), LabelValue(..), color, fillColor, fontColor, fontSize, htmlLabel, label, penWidth, style) as Export
+import Data.DotLang.Attr.Common as Common
+import Data.DotLang.Class (class DotLangValue)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
+import Data.Maybe (Maybe(..))
+import Record as Record
-data LabelValue
- = TextLabel String
- | HtmlLabel String
-
-derive instance genericLabel :: Generic LabelValue _
+type Attributes
+ = Common.Attributes
+ ( margin :: Maybe Int
+ , width :: Maybe Int
+ , shape :: Maybe ShapeType
+ )
-instance showLabel :: Show LabelValue where
- show = genericShow
+defaultAttributes :: { | Attributes }
+defaultAttributes =
+ Common.defaultAttributes
+ `Record.disjointUnion`
+ { margin: Nothing
+ , width: Nothing
+ , shape: Nothing
+ }
-data Attr
- = Color Color
- | Margin Int
- | FontColor Color
- | FontSize Int
- | Width Int
- | Label LabelValue
- | Shape ShapeType
- | Style FillStyle
- | FillColor Color
- | PenWidth Number
+shape :: ShapeType -> Attribute { | Attributes }
+shape v = _ { shape = Just v }
-derive instance genericAttr :: Generic Attr _
+margin :: Int -> Attribute { | Attributes }
+margin v = _ { margin = Just v }
-instance showAttr :: Show Attr where
- show = genericShow
-
-instance attrDotLang :: DotLang Attr where
- toText (Margin i) = "margin="<> show i
- toText (Color s) = "color=\"" <> toHexString s <> "\""
- toText (FontColor s) = "fontcolor=\"" <> toHexString s <> "\""
- toText (FontSize i) = "fontsize="<> show i
- toText (Width i) = "width="<> show i
- toText (Shape t) = "shape="<> toText t
- toText (Style f) = "style="<> toText f
- toText (Label (TextLabel t)) = "label=" <> show t
- toText (Label (HtmlLabel t)) = "label=" <> t
- toText (FillColor c) = "fillcolor=\"" <> toHexString c <> "\""
- toText (PenWidth i) = "penwidth="<> show i
+width :: Int -> Attribute { | Attributes }
+width v = _ { width = Just v }
-- | possible node shapes
data ShapeType
- = Box | Polygon | Ellipse | Oval | Circle | Point | Egg
- | Triangle | Plaintext | Plain | Diamond | Trapezium | Parallelogram
- | House | Pentagon | Hexagon | Septagon | Octagon | Doublecircle
- | Doubleoctagon | Tripleoctagon | Invtriangle | Invtrapezium
- | Invhouse | Mdiamond | Msquare | Mcircle | Rect | Rectangle | Square
- | Star | None | Underline | Cylinder | Note | Tab | Folder | Box3d
- | Component | Promoter | Cds | Terminator | Utr | Primersite | Restrictionsite
- | Fivepoverhang | Threepoverhang | Noverhang | Assembly | Signature
- | Insulator | Ribosite | Rnastab | Proteasesite | Proteinstab | Rpromoter
- | Rarrow | Larrow | Lpromoter
+ = Box
+ | Polygon
+ | Ellipse
+ | Oval
+ | Circle
+ | Point
+ | Egg
+ | Triangle
+ | Plaintext
+ | Plain
+ | Diamond
+ | Trapezium
+ | Parallelogram
+ | House
+ | Pentagon
+ | Hexagon
+ | Septagon
+ | Octagon
+ | Doublecircle
+ | Doubleoctagon
+ | Tripleoctagon
+ | Invtriangle
+ | Invtrapezium
+ | Invhouse
+ | Mdiamond
+ | Msquare
+ | Mcircle
+ | Rect
+ | Rectangle
+ | Square
+ | Star
+ | None
+ | Underline
+ | Cylinder
+ | Note
+ | Tab
+ | Folder
+ | Box3d
+ | Component
+ | Promoter
+ | Cds
+ | Terminator
+ | Utr
+ | Primersite
+ | Restrictionsite
+ | Fivepoverhang
+ | Threepoverhang
+ | Noverhang
+ | Assembly
+ | Signature
+ | Insulator
+ | Ribosite
+ | Rnastab
+ | Proteasesite
+ | Proteinstab
+ | Rpromoter
+ | Rarrow
+ | Larrow
+ | Lpromoter
derive instance genericShapeType :: Generic ShapeType _
instance showShapeType :: Show ShapeType where
show = genericShow
-instance dotLangShape :: DotLang ShapeType where
- toText Box = "box"
- toText Polygon = "polygon"
- toText Ellipse = "ellipse"
- toText Oval = "oval"
- toText Circle = "circle"
- toText Point = "point"
- toText Egg = "egg"
- toText Triangle = "triangle"
- toText Plaintext = "plaintext"
- toText Plain = "plain"
- toText Diamond = "diamond"
- toText Trapezium = "trapezium"
- toText Parallelogram = "parallelogram"
- toText House = "house"
- toText Pentagon = "pentagon"
- toText Hexagon = "hexagon"
- toText Septagon = "septagon"
- toText Octagon = "octagon"
- toText Doublecircle = "doublecircle"
- toText Doubleoctagon = "doubleoctagon"
- toText Tripleoctagon = "tripleoctagon"
- toText Invtriangle = "invtriangle"
- toText Invtrapezium = "invtrapezium"
- toText Invhouse = "invhouse"
- toText Mdiamond = "mdiamond"
- toText Msquare = "msquare"
- toText Mcircle = "mcircle"
- toText Rect = "rect"
- toText Rectangle = "rectangle"
- toText Square = "square"
- toText Star = "star"
- toText None = "none"
- toText Underline = "underline"
- toText Cylinder = "cylinder"
- toText Note = "note"
- toText Tab = "tab"
- toText Folder = "folder"
- toText Box3d = "box3d"
- toText Component = "component"
- toText Promoter = "promoter"
- toText Cds = "cds"
- toText Terminator = "terminator"
- toText Utr = "utr"
- toText Primersite = "primersite"
- toText Restrictionsite = "restrictionsite"
- toText Fivepoverhang = "fivepoverhang"
- toText Threepoverhang = "threepoverhang"
- toText Noverhang = "noverhang"
- toText Assembly = "assembly"
- toText Signature = "signature"
- toText Insulator = "insulator"
- toText Ribosite = "ribosite"
- toText Rnastab = "rnastab"
- toText Proteasesite = "proteasesite"
- toText Proteinstab = "proteinstab"
- toText Rpromoter = "rpromoter"
- toText Rarrow = "Rarrow"
- toText Larrow = "Larrow"
- toText Lpromoter = "Lpromoter"
-
--- |
--- | ```purescript
--- | htmlLabel "" -- :: Attr
--- | ```
--- | htmlLabel as a part of an attribute of a node.
-htmlLabel :: String -> Attr
-htmlLabel = HtmlLabel >>> Label
-
--- |
--- | ```purescript
--- | textLabel "..." -- :: Attr
--- | ```
--- | label as a part of an attribute of a node.
-label :: String -> Attr
-label = TextLabel >>> Label
+instance dotLangShape :: DotLangValue ShapeType where
+ toValue Box = "box"
+ toValue Polygon = "polygon"
+ toValue Ellipse = "ellipse"
+ toValue Oval = "oval"
+ toValue Circle = "circle"
+ toValue Point = "point"
+ toValue Egg = "egg"
+ toValue Triangle = "triangle"
+ toValue Plaintext = "plaintext"
+ toValue Plain = "plain"
+ toValue Diamond = "diamond"
+ toValue Trapezium = "trapezium"
+ toValue Parallelogram = "parallelogram"
+ toValue House = "house"
+ toValue Pentagon = "pentagon"
+ toValue Hexagon = "hexagon"
+ toValue Septagon = "septagon"
+ toValue Octagon = "octagon"
+ toValue Doublecircle = "doublecircle"
+ toValue Doubleoctagon = "doubleoctagon"
+ toValue Tripleoctagon = "tripleoctagon"
+ toValue Invtriangle = "invtriangle"
+ toValue Invtrapezium = "invtrapezium"
+ toValue Invhouse = "invhouse"
+ toValue Mdiamond = "mdiamond"
+ toValue Msquare = "msquare"
+ toValue Mcircle = "mcircle"
+ toValue Rect = "rect"
+ toValue Rectangle = "rectangle"
+ toValue Square = "square"
+ toValue Star = "star"
+ toValue None = "none"
+ toValue Underline = "underline"
+ toValue Cylinder = "cylinder"
+ toValue Note = "note"
+ toValue Tab = "tab"
+ toValue Folder = "folder"
+ toValue Box3d = "box3d"
+ toValue Component = "component"
+ toValue Promoter = "promoter"
+ toValue Cds = "cds"
+ toValue Terminator = "terminator"
+ toValue Utr = "utr"
+ toValue Primersite = "primersite"
+ toValue Restrictionsite = "restrictionsite"
+ toValue Fivepoverhang = "fivepoverhang"
+ toValue Threepoverhang = "threepoverhang"
+ toValue Noverhang = "noverhang"
+ toValue Assembly = "assembly"
+ toValue Signature = "signature"
+ toValue Insulator = "insulator"
+ toValue Ribosite = "ribosite"
+ toValue Rnastab = "rnastab"
+ toValue Proteasesite = "proteasesite"
+ toValue Proteinstab = "proteinstab"
+ toValue Rpromoter = "rpromoter"
+ toValue Rarrow = "Rarrow"
+ toValue Larrow = "Larrow"
+ toValue Lpromoter = "Lpromoter"
diff --git a/src/Data/DotLang/Class.purs b/src/Data/DotLang/Class.purs
index fafb72d..ab03b1a 100644
--- a/src/Data/DotLang/Class.purs
+++ b/src/Data/DotLang/Class.purs
@@ -1,5 +1,20 @@
module Data.DotLang.Class where
+import Prelude
+import Color (Color, toHexString)
+
-- | `a` is a type that has a representation in the dot language
class DotLang a where
toText :: a -> String
+
+class DotLangValue a where
+ toValue :: a -> String
+
+instance color :: DotLangValue Color where
+ toValue v = "\"" <> toHexString v <> "\""
+
+instance int :: DotLangValue Int where
+ toValue = show
+
+instance number :: DotLangValue Number where
+ toValue = show
\ No newline at end of file
diff --git a/test/Main.purs b/test/Main.purs
index e231063..4a04437 100644
--- a/test/Main.purs
+++ b/test/Main.purs
@@ -3,13 +3,13 @@ module Test.Main where
import Prelude
import Color.Scheme.MaterialDesign (red)
-import Data.DotLang (Definition(..), Graph(..), Edge(..), EdgeType(..), global, node, (==>), (=*>))
-import Data.DotLang.Attr (FillStyle(..))
-import Data.DotLang.Attr.Edge as Edge
-import Data.DotLang.Attr.Node (Attr(..), ShapeType(..))
+import Data.DotLang (Definition(..), Edge(..), EdgeType(..), Graph(..), edge, global, node, (=*>), (==>))
+import Data.DotLang.Attr.Common (FillStyle(..), fillColor, style)
+import Data.DotLang.Attr.Edge (arrowHead)
+import Data.DotLang.Attr.Global (RankDirValue(..), rankDir)
+import Data.DotLang.Attr.Node (shape)
import Data.DotLang.Attr.Node as Node
-import Data.DotLang.Attr.Global (RankDirValue(..))
-import Data.DotLang.Attr.Global as Global
+import Data.DotLang.Attr.Edge as Edge
import Data.DotLang.Class (toText)
import Effect (Effect)
import Test.Unit (suite, test)
@@ -17,23 +17,26 @@ import Test.Unit.Assert (equal)
import Test.Unit.Main (runTest)
main ∷ Effect Unit
-main = runTest do
- suite "DotLang" do
- test "basic test" do
- let
- g = DiGraph [
- global [ Global.RankDir FromLeft ],
- node "a" [ Shape Diamond, Style Filled, Node.FillColor red ],
- node "b" [],
- "a" ==> "b",
- "a" =*> "d" $ [ Edge.FillColor red ],
- Subgraph [
- node "d" []
- ]
- ]
- equal "digraph {rankdir=LR; a [shape=diamond, style=filled, fillcolor=\"#f44336\"]; b []; a -> b; a -> d [fillcolor=\"#f44336\"]; subgraph { d []; }}" (toText g)
- test "examples from documentation" do
- equal (toText $ Edge Forward "a" "b" []) "a -> b"
- equal (toText $ "a" =*> "b" $ [ Edge.FillColor red ]) "a -> b [fillcolor=\"#f44336\"]; "
- test "ArrowHead" $ do
- equal (toText $ "a" =*> "b" $ [ Edge.ArrowHead Edge.None ]) "a -> b [arrowhead=none]; "
+main =
+ runTest do
+ suite "DotLang" do
+ test "basic test" do
+ let
+ g =
+ DiGraph
+ [ global [ rankDir FromLeft ]
+ , node "a" [ shape Node.Diamond, style Filled, fillColor red ]
+ , node "b" []
+ , "a" ==> "b"
+ , "a" =*> "d" $ [ fillColor red ]
+ , Subgraph
+ [ node "d" []
+ ]
+ ]
+ equal "digraph {rankdir=LR; a [fillcolor=\"#f44336\", shape=diamond, style=filled]; b []; a -> b; a -> d [fillcolor=\"#f44336\"]; subgraph { d []; }}" (toText g)
+ test "examples from documentation" do
+ equal "a -> b; " (toText $ edge Forward "a" "b" [])
+ equal "a -> b [fillcolor=\"#f44336\"]; " (toText $ "a" =*> "b" $ [ fillColor red ])
+ test "ArrowHead"
+ $ do
+ equal (toText $ "a" =*> "b" $ [ arrowHead Edge.None ]) "a -> b [arrowhead=none]; "