-
Notifications
You must be signed in to change notification settings - Fork 150
/
Main.hs
122 lines (112 loc) · 4.99 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
{-# LANGUAGE OverloadedStrings #-}
module Main
(main)
where
import Control.Applicative ((<|>))
import Control.Monad (forM_, guard)
import qualified Data.ByteString as SB
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text.Lazy as L
import System.Exit (exitFailure)
import System.IO (hClose, hPutStrLn, stderr)
import Data.GraphViz
import qualified Data.GraphViz.Attributes.Colors.X11 as C
import qualified Data.GraphViz.Attributes.Complete as A
import qualified Data.GraphViz.Attributes.HTML as H
import qualified Data.GraphViz.Types.Generalised as G
import Data.GraphViz.Types.Monadic
import Erd.Config
import Erd.ER
import Erd.Parse
import Erd.Render (htmlAttr, htmlFont,
recordAttr, withLabelFmt)
main :: IO ()
main = do
checkRequirements -- application may terminate here
conf <- configIO
er' <- uncurry loadER (cin conf)
case er' of
Left err -> do
hPutStrLn stderr err
exitFailure
Right er -> let erDot = dotER conf er
toFile h = SB.hGetContents h >>= SB.hPut (snd $ cout conf)
fmt = fromMaybe Pdf (outfmt conf)
in graphvizWithHandle Dot erDot fmt toFile
hClose (snd $ cin conf)
hClose (snd $ cout conf)
-- | Converts an entire ER-diagram from an ER file into a GraphViz graph.
dotER :: Config -> ER -> G.DotGraph L.Text
dotER conf er = graph' $ do
graphAttrs (graphTitle $ title er)
graphAttrs [ A.RankDir A.FromLeft
, A.Splines $ fromConfigOrDefault edgeType
]
nodeAttrs nodeGlobalAttributes
edgeAttrs [ A.Color [A.toWC $ A.toColor C.Gray50] -- easier to read labels
, A.MinLen 2 -- give some breathing room
, A.Style [A.SItem (fromConfigOrDefault edgePattern) [] ]
]
forM_ (entities er) $ \e ->
node (name e) [entityFmt e]
forM_ (rels er) $ relToEdge (fromConfigOrDefault notation)
where
fromConfigOrDefault :: (Config -> Maybe a) -> a
fromConfigOrDefault opt = fromJust $ opt conf <|> opt defaultConfig
nodeGlobalAttributes
| fromConfigOrDefault dotentity = [shape Record, A.RankDir A.FromTop]
| otherwise = [shape PlainText] -- recommended for HTML labels
entityFmt
| fromConfigOrDefault dotentity = toLabel . dotEntity
| otherwise = toLabel . htmlEntity
relToEdge n r = edge (entity1 r) (entity2 r) (label:eAttr n)
where
optss = roptions r
label = A.Label $ A.HtmlLabel $ H.Text $ withLabelFmt " %s " optss []
(c1,c2) = (card1 r, card2 r)
eAttr UML = [A.TailLabel $ card2label c1
,A.HeadLabel $ card2label c2
]
where
card2label = A.HtmlLabel . H.Text . htmlFont optss . L.pack . show
eAttr IE = [A.Dir Both
,A.ArrowTail $ card2arr c1
,A.ArrowHead $ card2arr c2
]
where
card2arr ZeroOne = A.AType [(A.openMod, A.DotArrow), (A.noMods, A.Tee)]
card2arr One = A.AType [(A.noMods, A.Tee), (A.noMods, A.Tee)]
card2arr ZeroPlus = A.AType [(A.noMods, A.Crow), (A.openMod, A.DotArrow)]
card2arr OnePlus = A.AType [(A.noMods, A.Crow), (A.noMods, A.Tee)]
-- | Converts a single entity to an HTML label.
htmlEntity :: Entity -> H.Label
htmlEntity e = H.Table H.HTable
{ H.tableFontAttrs = Just $ optionsTo optToFont $ eoptions e
, H.tableAttrs = optionsTo optToHtml (eoptions e)
, H.tableRows = rows
}
where rows = headerRow : map htmlAttr (attribs e)
headerRow = H.Cells [H.LabelCell [] $ H.Text text]
text = withLabelFmt " [%s]" (hoptions e) $ boldFont hname
hname = htmlFont (hoptions e) (name e)
boldFont s = [H.Format H.Bold s]
-- | Converts a single entity to a plain Dot Label
dotEntity :: Entity -> A.RecordFields
dotEntity e = A.FieldLabel ( name e ) : map recordAttr (attribs e)
-- | Extracts and formats a graph title from the options given.
-- The options should be title options from an ER value.
-- If a title does not exist, an empty list is returned and `graphAttrs attrs`
-- should be a no-op.
graphTitle :: Options -> [A.Attribute]
graphTitle topts =
let glabel = optionsTo optToLabel topts
in if null glabel then [] else
[ A.LabelJust A.JLeft
, A.LabelLoc A.VTop
, A.Label $ A.HtmlLabel $ H.Text $ htmlFont topts (head glabel)
]
checkRequirements :: IO ()
checkRequirements = (isGraphvizInstalled >>= guard) <|> quitWithoutGraphviz msg
where
msg = "GraphViz is not installed on your system.\n" ++
"Please install it first, https://github.com/BurntSushi/erd"