{-|
Module : MetaHS.EDSL.Graph.UsesGraph
Description : Generates a Uses graph for a module
Copyright : Copyright (C) 2017-2019 H.H.R.F. Vos, S. Kamps
License : -- This file is distributed under the terms of the Apache License 2.0.
For more information, see the file "LICENSE", which is included in the distribution.
Stability : experimental
Generates a Uses graph for a module
-}
module MetaHS.EDSL.Graph.UsesGraph
( internalUses
, internalUsesGraph
, internalUsesParams
) where
import Data.Maybe (fromMaybe)
import Data.List (nub, elemIndex)
import Data.Text.Lazy (Text, pack)
import Data.Graph.Inductive
import Data.GraphViz
import Data.GraphViz.Attributes.Complete
import MetaHS.DataModel.MetaModel
import MetaHS.EDSL.MetaModel
import MetaHS.EDSL.Graph.Types
import MetaHS.EDSL.Utils
-- | Generates the internal uses graph for the specified module and returns
-- the associated default GraphvizParams.
internalUses :: MetaModel -- ^ The meta-model.
-> Element -- ^ The module.
-> Directed -- ^ This option will determine whether the resulting graph is directed or undirected.
-> String -- ^ The prefix for the links in the generated SVG images to the correct HTML editor for displaying the source code. Should probably become a hard link if a web server is used.
-> (GraphType,ParamsType) -- ^ The generated Graph.
internalUses metaModel moduleElement directed editorLink = (graph,params)
where
graph = internalUsesGraph metaModel moduleElement directed
params = internalUsesParams metaModel moduleElement directed editorLink
-- | Generates the internal uses graph for the specified module.
internalUsesGraph :: MetaModel -- ^ The meta-model.
-> Element -- ^ The module.
-> Directed -- ^ This option will determine whether the resulting graph is directed or undirected.
-> GraphType -- ^ The generated Graph.
internalUsesGraph metaModel moduleElement directed = graph
where
graph = mkGraph ns es
elements = [m | m <- mc, isInteresting m]
mc = moduleContains metaModel moduleElement
ns :: [LNode Element]
ns = zipWith f [0..] elements -- ns = nodes
where
f :: Int -> Element -> LNode Element
f i e = (i, e)
es :: [LEdge Text] -- es = edges
es = concat [f a b | a <- elements, b <- elementUses metaModel a]
where
f :: Element -> Element -> [LEdge Text]
f a b = nub $ fromMaybe [] $ mkLEdge <$> ia <*> ib
where
mkLEdge :: Int -> Int -> [LEdge Text]
mkLEdge x y = case directed of
Directed -> [(x, y, pack "")] -- directed graphs
Undirected -> [(x, y, pack ""), (y, x, pack "")] -- undirected graphs require A -> B AND B -> A in order to come to A -- B
ia = elemIndex a elements
ib = elemIndex b elements
-- | Generates the default GraphvizParams for the internal uses graph for the
-- specified module.
internalUsesParams :: MetaModel -- ^ The meta-model.
-> Element -- ^ The module.
-> Directed -- ^ This option will determine whether the resulting graph is directed or undirected.
-> String -- ^ The prefix for the links in the generated SVG images to the correct HTML editor for display the source code. Should probably become a hard link if a web server is used.
-> ParamsType -- ^ The generated Graph.
internalUsesParams metaModel moduleElement directed editorLink =
nonClusteredParams
{ isDirected = case directed of -- undirected graphs require A -> B AND B -> A in order to come to A -- B
Directed -> True
Undirected -> False
, globalAttributes = globAttr
, fmtNode = formatNode
, fmtEdge = const []
}
where
globAttr =
[GraphAttrs
[Label . StrLabel . pack $ name moduleElement
,Overlap ScaleXYOverlaps
]
]
formatNode (_, fe@(Function qn)) =
[qnToLabel qn
,shape BoxShape
,styles [bold, filled]
,FillColor [toWC (RGBA 0xFF 0xFF 0xFF 0x40)] -- White, alpha=0.25
,Color [toWC (RGBA 0x00 0x00 0x00 0xFF)] -- Black, alpha=1.00
,URL $ urlQuery metaModel fe
]
formatNode (_, dte@(DataType qn)) =
[qnToLabel qn
,shape BoxShape
,styles [bold, filled]
,FillColor [toWC (RGBA 0x41 0xA3 0x17 0x40)] -- LimeGreen, alpha=0.25
,Color [toWC (RGBA 0x41 0xA3 0x17 0xFF)] -- LimeGreen, alpha=1.00
,URL $ urlQuery metaModel dte
]
formatNode (_, tse@(TypeSynonym qn)) =
[qnToLabel qn
,shape BoxShape
,styles [bold, filled]
,FillColor [toWC (RGBA 0x2B 0x65 0xEC 0x40)] -- OceanBlue; alpha=0.25
,Color [toWC (RGBA 0x2B 0x65 0xEC 0xFF)] -- OceanBlue, alpha=1.00
,URL $ urlQuery metaModel tse
]
formatNode (_, e) = [qnToLabel $ name e]
qnToLabel qn = Label $ StrLabel . pack . snd $ split qn
urlQuery mm e = pack $ case elementSource mm e of
Just s -> editorLink ++ locationToQuery s
_ -> ""
-- | The Elements for which the lcom is measured.
isInteresting :: Element -> Bool
isInteresting TypeSynonym{} = True
isInteresting DataType{} = True
isInteresting Function{} = True
isInteresting _ = False