-
Notifications
You must be signed in to change notification settings - Fork 150
/
Main.hs
118 lines (106 loc) · 4.43 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
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Applicative ((<|>))
import Control.Monad (forM_, guard)
import qualified Data.ByteString as SB
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as L
import System.Exit (exitFailure)
import System.IO (hClose, hPutStrLn, stderr)
import Text.Printf (printf)
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 Data.GraphViz.Commands (isGraphvizInstalled)
import qualified Erd.ER as ER
import Erd.Config
import Erd.ER
import Erd.Parse
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 dotted = dotER conf er
toFile h = SB.hGetContents h >>= SB.hPut (snd $ cout conf)
fmt = fromMaybe Pdf (outfmt conf)
in graphvizWithHandle Dot dotted 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 (edgeType conf)
]
nodeAttrs [shape PlainText] -- recommended for HTML labels
edgeAttrs [ A.Color [A.toWC $ A.toColor C.Gray50] -- easier to read labels
, A.MinLen 2 -- give some breathing room
, A.Style [A.SItem A.Dashed []] -- easier to read labels, maybe?
]
forM_ (entities er) $ \e ->
node (name e) [toLabel (htmlEntity e)]
forM_ (rels er) $ \r -> do
let opts = roptions r
let rlab = A.HtmlLabel . H.Text . htmlFont opts . L.pack . show
let (l1, l2) = (A.TailLabel $ rlab $ card1 r, A.HeadLabel $ rlab $ card2 r)
let label = A.Label $ A.HtmlLabel $ H.Text $ withLabelFmt " %s " opts []
edge (entity1 r) (entity2 r) [label, l1, l2]
-- | 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) $ bold hname
hname = htmlFont (hoptions e) (name e)
bold s = [H.Format H.Bold s]
-- | Converts a single attribute to an HTML table row.
htmlAttr :: ER.Attribute -> H.Row
htmlAttr a = H.Cells [cell]
where cell = H.LabelCell cellAttrs (H.Text $ withLabelFmt " [%s]" opts name)
name = fkfmt $ pkfmt $ htmlFont opts (field a)
pkfmt s = if pk a then [H.Format H.Underline s] else s
fkfmt s = if fk a then [H.Format H.Italics s] else s
cellAttrs = H.Align H.HLeft : optionsTo optToHtml opts
opts = aoptions a
-- | Formats HTML text with a label. The format string given should be
-- in `Data.Text.printf` style. (Only font options are used from the options
-- given.)
withLabelFmt :: String -> Options -> H.Text -> H.Text
withLabelFmt fmt opts s =
case optionsTo optToLabel opts of
(x:_) -> s ++ htmlFont opts (L.pack $ printf fmt $ L.unpack x)
_ -> s
-- | Formats an arbitrary string with the options given (using only font
-- attributes).
htmlFont :: Options -> L.Text -> H.Text
htmlFont opts s = [H.Font (optionsTo optToFont opts) [H.Str s]]
-- | 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"