{- Copyright (C) 2010 Ivan Lazar Miljenovic 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 Parsing.Types import Analyse.GraphRepr import Analyse.Utils import Analyse.Colors import Data.Graph.Analysis hiding (Bold) import Data.GraphViz import Data.GraphViz.Attributes.Complete(Attribute(Margin), DPoint(PVal), createPoint) import Data.Maybe(isNothing) import Data.List(find) 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 hasEdge $ edgeCols d where hasEdge = S.member e . fst