ampersand-3.1.0: src/Database/Design/Ampersand/Graphic/ClassDiag2Dot.hs
module Database.Design.Ampersand.Graphic.ClassDiag2Dot (
classdiagram2dot
)
where
import Data.List
import Database.Design.Ampersand.Basics
import Database.Design.Ampersand.Classes
import Database.Design.Ampersand.ADL1 hiding (Association,Box)
import Database.Design.Ampersand.Misc
import Data.String
import Data.GraphViz.Types.Canonical hiding (attrs)
import Data.GraphViz.Attributes.Complete as GVcomp
import Data.GraphViz.Attributes as GVatt
import Data.GraphViz.Attributes.HTML as Html
import Database.Design.Ampersand.Graphic.ClassDiagram
-- | translate a ClassDiagram to a DotGraph, so it can be used to show it as a picture.
classdiagram2dot :: Options -> ClassDiag -> DotGraph String
classdiagram2dot opts cd
= DotGraph { strictGraph = False
, directedGraph = True
, graphID = Nothing
, graphStatements =
DotStmts
{ attrStmts = [ GraphAttrs [ RankDir FromLeft
, bgColor White]
]
-- ++ [NodeAttrs [ ]]
++ [EdgeAttrs [ FontSize 11
, MinLen 4
] ]
, subGraphs = []
, nodeStmts = allNodes (classes cd) (nodes cd >- nodes (classes cd))
, edgeStmts = (map association2edge (assocs cd)) ++
(map aggregation2edge (aggrs cd)) ++
(concatMap generalization2edges (geners cd))
}
}
where
allNodes :: [Class] -> [String] -> [DotNode String]
allNodes cs others =
map class2node cs ++
map nonClass2node others
class2node :: Class -> DotNode String
class2node cl = DotNode
{ nodeID = name cl
, nodeAttributes = [ Shape PlainText
, GVcomp.Color [WC (X11Color Purple) Nothing]
, Label (HtmlLabel (Table htmlTable))
]
} where
htmlTable = HTable { tableFontAttrs = Nothing
, tableAttrs = [ Html.BGColor (X11Color White)
, Html.Color (X11Color Black) -- the color used for all cellborders
, Html.Border 0 -- 0 = no border
, CellBorder 1
, CellSpacing 0
]
, tableRows = [ Cells -- Header row, containing the name of the class
[ LabelCell
[ Html.BGColor (X11Color Gray10)
, Html.Color (X11Color Black)
]
(Html.Text [ Html.Font [ Html.Color (X11Color White)
]
[Html.Str (fromString (name cl))]
]
)
]
]++
map attrib2row (clAtts cl) ++
map method2row (clMths cl)
}
where
attrib2row a = Cells
[ Html.LabelCell [ Html.Align HLeft
, (Port .PN .fromString) (attNm a)
]
( Html.Text [ Html.Str (fromString (if attOptional a then "o " else "+ "))
, Html.Str (fromString (name a))
, Html.Str (fromString " : ")
, Html.Str (fromString (attTyp a))
]
)
]
method2row m = Cells
[ Html.LabelCell [ Html.Align HLeft]
( Html.Text [ Html.Str (fromString "+ ")
, Html.Str (fromString (show m))
]
)
]
nonClass2node :: String -> DotNode String
nonClass2node str = DotNode { nodeID = str
, nodeAttributes = [ Shape Box3D
, Label (StrLabel (fromString str))
]
}
---- In order to make classes, all relations that are univalent and injective are flipped
---- attRels contains all relations that occur as attributes in classes.
-- attRels = [r |r<-rels, isUni r, not (isInj r)] ++[flp r |r<-rels, not (isUni r), isInj r] ++
-- [r |r<-rels, isUni r, isInj r, isSur r]++[flp r |r<-rels, isUni r , isInj r, not (isSur r)]
---- assRels contains all relations that do not occur as attributes in classes
-- assRels = [r |r<-relsLim, not (isUni r), not (isInj r)]
-- attrs rs = [ OOAttr ((name.head.relsMentionedIn) r) (name (target r)) (not(isTot r))
-- | r<-rs, not (isPropty r)]
-- isPropty r = null([Sym,Asy]>-multiplicities r)
-------------------------------
-- ASSOCIATIONS: --
-------------------------------
association2edge :: Association -> DotEdge String
association2edge ass =
DotEdge { fromNode = assSrc ass
, toNode = assTgt ass
, edgeAttributes = [ ArrowHead (AType [(ArrMod OpenArrow BothSides, NoArrow)]) -- No arrowHead
, HeadLabel (mult2Lable (assrhm ass))
, TailLabel (mult2Lable (asslhm ass))
, Label (StrLabel (fromString (assrhr ass)))
, LabelFloat True
]
++[(TailPort (LabelledPort (PN ((fromString.assSrcPort) ass)) Nothing))]
}
where
mult2Lable = StrLabel . fromString . mult2Str
mult2Str (Mult MinZero MaxOne) = "0-1"
mult2Str (Mult MinZero MaxMany) = "*"
mult2Str (Mult MinOne MaxOne) = "1"
mult2Str (Mult MinOne MaxMany) = "1-*"
-------------------------------
-- AGGREGATIONS: --
-------------------------------
aggregation2edge :: Aggregation -> DotEdge String
aggregation2edge agg =
DotEdge { fromNode = name . aggChild $ agg
, toNode = name . aggParent $ agg
, edgeAttributes = [ ArrowHead (AType [(ArrMod (case aggDel agg of
Open -> OpenArrow
Close -> FilledArrow
) BothSides , Diamond)
])
]
}
-------------------------------
-- GENERALIZATIONS: -- -- Ampersand statements such as "SPEC Dolphin ISA Animal" are called generalization.
-- -- -- Generalizations are represented by a red arrow with a (larger) open triangle as arrowhead
-------------------------------
generalization2edges :: Generalization -> [DotEdge String]
generalization2edges ooGen = sub2edges (genAgen ooGen)
where
sub2edges gen
= [DotEdge { fromNode = name spec
, toNode = name gener
, edgeAttributes
= [ ArrowHead (AType [(ArrMod OpenArrow BothSides, Normal)]) -- Open normal arrowHead
, ArrowSize 2.0
] ++
( if blackWhite opts
then [Style [SItem Dashed []]]
else [GVcomp.Color [WC (X11Color Red) Nothing]]
)
}
| (spec,gener)<-splits gen]
splits gen = case gen of
Isa{} -> [(genspc gen, gengen gen)]
IsE{} -> [(genspc gen, x ) | x<-(genrhs gen)]
class CdNode a where
nodes :: a->[String]
instance CdNode ClassDiag where
nodes cd = nub (concat ( map nodes (classes cd)
++map nodes (assocs cd)
++map nodes (aggrs cd)
++map nodes (geners cd)
) )
instance CdNode Class where
nodes cl = [clName cl]
instance CdNode a => CdNode [a] where
nodes = concatMap nodes
instance CdNode Association where
nodes a = [assSrc a,assTgt a]
instance CdNode Aggregation where
nodes (OOAggr _ s t) = map name [s,t]
instance CdNode Generalization where
nodes g = map name ((concs.genAgen) g)