SourceGraph-0.7.0.7: Analyse/Visualise.hs
{-
Copyright (C) 2010 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>
This file is part of SourceGraph.
SourceGraph is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- |
Module : Analyse.Visualise
Description : Visualisation functions.
Copyright : (c) Ivan Lazar Miljenovic 2010
License : GPL-3 or later.
Maintainer : Ivan.Miljenovic@gmail.com
Utility functions and types for analysis.
-}
module Analyse.Visualise where
import Analyse.Colors
import Analyse.GraphRepr
import Analyse.Utils
import Parsing.Types
import Data.Graph.Analysis hiding (Bold)
import Data.GraphViz
import Data.GraphViz.Attributes.Complete (Attribute (Margin), DPoint (PVal),
createPoint)
import Data.List (find)
import Data.Maybe (isNothing)
import qualified Data.Set as S
-- -----------------------------------------------------------------------------
-- | Create the nested 'DotGraph'.
drawGraph :: String -> Maybe ModName -> HData' -> DotGraph Node
drawGraph gid mm dg = setID (toGraphID gid)
. graphviz params $ compactData dg'
where
params = Params True gAttrs toClust isClust ctypeID clustAttributes' nAttr eAttr
dg' = origHData dg
gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]
-- Possible clustering problem
toClust = clusterEntity -- bool clusterEntity clusterEntityM' $ isJust mm
isClust = const True
nAttr = entityAttributes dg' (isNothing mm) mm
eAttr = callAttributes' dg'
-- | One-module-per-cluster 'DotGraph'.
drawGraph' :: String -> HData' -> DotGraph Node
drawGraph' gid dg = setID (toGraphID gid)
. graphvizClusters params $ compactData dg'
where
params = Params True gAttrs N undefined undefined modClustAttrs nAttr eAttr
dg' = collapsedHData dg
gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]
nAttr = entityAttributes dg' False Nothing
eAttr = callAttributes' dg'
-- -----------------------------------------------------------------------------
-- | 'True' if add explicit module name to all entities, @'Just' m@ if
-- only one module, @'Nothing'@ if all.
entityAttributes :: GData n e -> Bool -> Maybe ModName
-> LNode Entity -> Attributes
entityAttributes hd a mm (n,Ent m nm t)
= [ toLabel lbl
, shape $ shapeFor t
-- , Color ColorName cl
, fillColor $ entCol hd n
-- Have to re-set Filled because setting a new Style seems to
-- override global Style.
, styles [filled, styleFor mm m]
]
where
lbl = bool nm (nameOfModule m ++ "\\n" ++ nm)
$ not sameMod || a
sameMod = maybe True (m==) mm
shapeFor :: EntityType -> Shape
shapeFor Constructor{} = Box3D
shapeFor RecordFunction{} = Component
shapeFor ClassMethod{} = DoubleOctagon
shapeFor DefaultInstance{} = Octagon
shapeFor ClassInstance{} = Octagon
shapeFor CollapsedData{} = Box3D
shapeFor CollapsedClass{} = DoubleOctagon
shapeFor CollapsedInstance{} = Octagon
shapeFor NormalEntity = BoxShape
styleFor :: Maybe ModName -> ModName -> Style
styleFor mm m@LocalMod{} = bool solid bold $ maybe False (m==) mm
styleFor _ ExtMod{} = dashed
styleFor _ UnknownMod = dotted
callAttributes :: GData n e -> Edge -> CallType
-> Attributes
callAttributes hd e NormalCall = [ color $ edgeCol hd e]
callAttributes _ _ InstanceDeclaration = [ color Navy
, edgeEnds NoDir
]
callAttributes _ _ DefaultInstDeclaration = [ color Turquoise
, edgeEnds NoDir
]
callAttributes _ _ RecordConstructor = [ color Magenta
, arrowFrom oDot
, arrowTo vee
]
callAttributes' :: GData n e -> LEdge (Int, CallType)
-> Attributes
callAttributes' hd (f,t,(n,ct)) = penWidth (log (fromIntegral n) + 1)
: callAttributes hd (f,t) ct
clustAttributes :: EntClustType -> Attributes
clustAttributes (ClassDefn c) = [ toLabel $ "Class: " ++ c
, styles [filled, rounded]
, fillColor RosyBrown1
]
clustAttributes (DataDefn d) = [ toLabel $ "Data: " ++ d
, styles [filled, rounded]
, fillColor PapayaWhip
]
clustAttributes (ClassInst _ d) = [ toLabel $ "Instance for: " ++ d
, styles [filled, rounded]
, fillColor SlateGray1
]
clustAttributes DefInst{} = [ toLabel $ "Default Instance"
, styles [filled, rounded]
, fillColor SlateGray1
]
clustAttributes (ModPath p) = [ toLabel p ]
clustAttributes' :: EntClustType -> [GlobalAttributes]
clustAttributes' = return . GraphAttrs . clustAttributes
modClustAttrs :: ModName -> [GlobalAttributes]
modClustAttrs m = [GraphAttrs [ toLabel $ nameOfModule m
, style filled
, fillColor clusterBackground
]
]
-- -----------------------------------------------------------------------------
-- | Create a 'DotGraph' using a clustering function. The clustering
-- function shouldn't touch the the actual 'Node' values.
drawClusters :: String -> (HSGraph -> HSClustGraph)
-> HData' -> DotGraph Node
drawClusters gid cf dg = setID (toGraphID gid)
. graphvizClusters params $ compactData dg'
where
params = blankParams { globalAttributes = gAttrs
, fmtCluster = const cAttr
, fmtNode = nAttr
, fmtEdge = eAttr
}
dg' = mapData' cf $ collapsedHData dg
gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]
cAttr = [GraphAttrs [ style filled
, fillColor clusterBackground
]
]
nAttr = entityAttributes dg' True Nothing
eAttr = callAttributes' dg'
drawLevels :: String -> Maybe ModName -> HData' -> DotGraph Node
drawLevels gid mm hd = setID (toGraphID gid)
$ graphvizClusters params dg'
where
params = blankParams { globalAttributes = gAttrs
, fmtCluster = levelAttr
, fmtNode = nAttr
, fmtEdge = eAttr
}
hd' = collapsedHData hd
vs = collapsedVirts hd
dg = compactData hd'
wrs = wantedRootNodes dg ++ S.toList (implicitExports vs dg)
dg' = updateGraph (levelGraphFrom wrs) dg
gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]
nAttr = entityAttributes hd' (isNothing mm) mm
eAttr = callAttributes' hd'
levelAttr :: Int -> [GlobalAttributes]
levelAttr l
| l < minLevel = atts "Inaccessible entities"
| l == minLevel = atts "Exported root entities"
| otherwise = atts $ "Level = " ++ show l
where
atts t = [GraphAttrs [ toLabel t
, style filled
, fillColor clusterBackground
]
]
-- -----------------------------------------------------------------------------
-- Dealing with inter-module imports, etc.
drawModules :: String -> MData -> DotGraph Node
drawModules gid md = setID (toGraphID gid)
. graphviz params $ graphData md
where
params = Params True gAttrs clusteredModule isClust cID cAttr nAttr eAttr
isClust = const True
cID (_,s) = bool undefined (toGraphID s) $ (not . null) s
gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]
cAttr dp = [GraphAttrs $ directoryAttributes dp]
nAttr (n,m) = [ toLabel m
, fillColor $ entCol md n
, shape Tab
]
eAttr le = [color . edgeCol md $ edge le]
directoryAttributes :: (Depth, String) -> Attributes
directoryAttributes (d,n) = col : [ style filled
, toLabel n
]
where
col = bool (fillColor noBackground) (fillColor clusterBackground)
$ d `mod` 2 == 0
-- -----------------------------------------------------------------------------
entCol :: GData n e -> Node -> X11Color
entCol d n = maybe defaultNodeColor snd
. find hasNode
$ nodeCols d
where
hasNode = S.member n . fst
nodeAttrs :: GlobalAttributes
nodeAttrs = NodeAttrs [ Margin . PVal $ createPoint 0.4 0.1
, style filled
]
edgeCol :: GData n e -> Edge -> X11Color
edgeCol d e = maybe defaultEdgeColor snd
. find hasE
$ edgeCols d
where
hasE = S.member e . fst