SourceGraph-0.5.5.0: Analyse/Utils.hs
{-
Copyright (C) 2009 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.Utils
Description : Utility functions and types for analysis.
Copyright : (c) Ivan Lazar Miljenovic 2009
License : GPL-3 or later.
Maintainer : Ivan.Miljenovic@gmail.com
Utility functions and types for analysis.
-}
module Analyse.Utils where
import Parsing.Types
import Data.Graph.Analysis hiding (Bold)
import Data.Graph.Inductive hiding (graphviz)
import Data.GraphViz
import Data.List(groupBy, sortBy)
import Data.Maybe(isJust)
import Data.Function(on)
import qualified Data.IntSet as I
import Data.IntSet(IntSet)
-- -----------------------------------------------------------------------------
type HSData = GraphData Entity CallType
type HSClustData = GraphData (GenCluster Entity) CallType
type HSGraph = AGr Entity CallType
type HSClustGraph = AGr (GenCluster Entity) CallType
type ModData = GraphData ModName ()
type ModGraph = AGr ModName ()
-- -----------------------------------------------------------------------------
-- | Cyclomatic complexity
cyclomaticComplexity :: GraphData a b -> Int
cyclomaticComplexity gd = e - n + 2*p
where
p = length $ applyAlg componentsOf gd
n = applyAlg noNodes gd
e = length $ applyAlg labEdges gd
-- | Collapse items that must be kept together before clustering, etc.
collapseStructures :: HSData -> HSData
collapseStructures = updateGraph collapseStructures'
collapseStructures' :: HSGraph -> HSGraph
collapseStructures' = collapseGraphBy' [ collapseDatas
, collapseClasses
, collapseInsts
]
where
collapseDatas = mkCollapseTp isData getDataType mkData
mkData m d = Ent m ("Data: " ++ d) (CollapsedData d)
collapseClasses = mkCollapseTp isClass getClassName mkClass
mkClass m c = Ent m ("Class: " ++ c) (CollapsedClass c)
collapseInsts = mkCollapseTp isInstance getInstance mkInst
mkInst m (c,d) = Ent m ("Class: " ++ c ++ ", Data: " ++ d)
(CollapsedInstance c d)
mkCollapseTp :: (Ord a) => (EntityType -> Bool) -> (EntityType -> a)
-> (ModName -> a -> Entity) -> HSGraph
-> [(NGroup, Entity)]
mkCollapseTp p v mkE g = map lng2ne lngs
where
lns = filter (p . eType . snd) $ labNodes g
lnas = map addA lns
lngs = groupSortBy snd lnas
lng2ne lng = ( map (fst . fst) lng
, mkEnt $ head lng
)
mkEnt ((_,e),a) = mkE (inModule e) a
addA ln@(_,l) = (ln, v $ eType l)
onlyNormalCalls :: HSData -> HSData
onlyNormalCalls = updateGraph go
where
go = elfilter isNormalCall
groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]]
groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f)
getRoots :: GraphData a b -> IntSet
getRoots = I.fromList . applyAlg rootsOf'
getLeaves :: GraphData a b -> IntSet
getLeaves = I.fromList . applyAlg leavesOf'
getWRoots :: GraphData a b -> IntSet
getWRoots = I.fromList . wantedRootNodes
entCol :: IntSet -> IntSet -> IntSet -> Node -> Color
entCol rs ls es n
| isR && not isE = unExportedRoot
| isR = exportedRoot
| isE = exportedInner
| isL = leafNode
| otherwise = innerNode
where
isR = n `I.member` rs
isL = n `I.member` ls
isE = n `I.member` es
unExportedRoot, exportedRoot, exportedInner, leafNode, innerNode :: Color
unExportedRoot = ColorName "crimson"
exportedRoot = ColorName "gold"
exportedInner = ColorName "goldenrod"
leafNode = ColorName "cyan"
innerNode = ColorName "bisque"
nodeAttrs :: GlobalAttributes
nodeAttrs = NodeAttrs [ Margin . PVal $ PointD 0.4 0.1
, Style [SItem Filled []]
]
bool :: a -> a -> Bool -> a
bool t f b = if b then t else f
-- -----------------------------------------------------------------------------
-- | Create the nested 'DotGraph'.
drawGraph :: String -> Maybe ModName -> HSData -> DotGraph Node
drawGraph gid mm dg = setID (Str gid)
$ graphvizClusters' dg'
gAttrs
toClust
ctypeID
clustAttributes'
nAttr
callAttributes'
where
gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]]
dg' = updateGraph compactSame dg
-- Possible clustering problem
toClust = clusterEntity -- bool clusterEntity clusterEntityM' $ isJust mm
rs = getRoots dg
ls = getLeaves dg
es = getWRoots dg
nAttr = entityAttributes rs ls es (not $ isJust mm) mm
-- | One-module-per-cluster 'DotGraph'
drawGraph' :: String -> HSData -> DotGraph Node
drawGraph' gid dg = setID (Str gid)
$ graphvizClusters dg'
gAttrs
modClustAttrs
nAttr
callAttributes'
where
gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]]
dg' = updateGraph (compactSame . collapseStructures') dg
rs = getRoots dg
ls = getLeaves dg
es = getWRoots dg
nAttr = entityAttributes rs ls es False Nothing
-- | GetRoots, GetLeaves, Exported, @'Just' m@ if only one module, @'Nothing'@ if all.
-- 'True' if add explicit module name to all entities.
entityAttributes :: IntSet -> IntSet -> IntSet -> Bool
-> Maybe ModName -> LNode Entity -> Attributes
entityAttributes rs ls ex a mm (n,(Ent m nm t))
= [ Label $ StrLabel lbl
, Shape $ shapeFor t
-- , Color [ColorName cl]
, FillColor $ entCol rs ls ex n
-- Have to re-set Filled because setting a new Style seems to
-- override global Style.
, Style [SItem Filled [], styleFor mm m]
]
where
lbl = bool (nameOfModule m ++ "\\n" ++ nm) nm
$ not sameMod || a
sameMod = maybe True ((==) m) mm
shapeFor :: EntityType -> Shape
shapeFor Constructor{} = Box3D
shapeFor RecordFunction{} = Component
shapeFor ClassFunction{} = DoubleOctagon
shapeFor DefaultInstance{} = Octagon
shapeFor ClassInstance{} = Octagon
shapeFor CollapsedData{} = Box3D
shapeFor CollapsedClass{} = DoubleOctagon
shapeFor CollapsedInstance{} = Octagon
shapeFor NormalEntity = BoxShape
styleFor :: Maybe ModName -> ModName -> StyleItem
styleFor mm m@LocalMod{} = flip SItem [] . bool Bold Solid
$ maybe True ((==) m) mm
styleFor _ ExtMod{} = SItem Dashed []
styleFor _ UnknownMod = SItem Dotted []
callAttributes :: CallType -> Attributes
callAttributes NormalCall = [ Color [ColorName "black"]]
callAttributes InstanceDeclaration = [ Color [ColorName "navy"]
, Dir NoDir
]
callAttributes DefaultInstDeclaration = [ Color [ColorName "turquoise"]
, Dir NoDir
]
callAttributes RecordConstructor = [ Color [ColorName "magenta"]
, ArrowTail oDot
, ArrowHead vee
]
callAttributes' :: LEdge (Int, CallType) -> Attributes
callAttributes' (_,_,(n,ct)) = PenWidth (fromIntegral n)
: callAttributes ct
clustAttributes :: EntClustType -> Attributes
clustAttributes (ClassDefn c) = [ Label . StrLabel $ "Class: " ++ c
, Style [SItem Filled [], SItem Rounded []]
, FillColor $ ColorName "rosybrown1"
]
clustAttributes (DataDefn d) = [ Label . StrLabel $ "Data: " ++ d
, Style [SItem Filled [], SItem Rounded []]
, FillColor $ ColorName "papayawhip"
]
clustAttributes (ClassInst _ d) = [ Label . StrLabel $ "Instance for: " ++ d
, Style [SItem Filled [], SItem Rounded []]
, FillColor $ ColorName "slategray1"
]
clustAttributes DefInst{} = [ Label . StrLabel $ "Default Instance"
, Style [SItem Filled [], SItem Rounded []]
, FillColor $ ColorName "slategray1"
]
clustAttributes (ModPath p) = [ Label $ StrLabel p ]
clustAttributes' :: EntClustType -> [GlobalAttributes]
clustAttributes' = return . GraphAttrs . clustAttributes
modClustAttrs :: ModName -> [GlobalAttributes]
modClustAttrs m = [GraphAttrs [ Label . StrLabel $ nameOfModule m
, Style [SItem Filled []]
, FillColor $ ColorName "lavender"
]
]
-- -----------------------------------------------------------------------------
-- | Create a 'DotGraph' using a clustering function.
drawClusters :: String -> (HSGraph -> HSClustGraph) -> HSData -> DotGraph Node
drawClusters gid cf dg = setID (Str gid)
$ graphvizClusters dg'
gAttrs
(const cAttr)
nAttr
callAttributes'
where
gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]]
cAttr = [GraphAttrs [ Style [SItem Filled []]
, FillColor $ ColorName "lavender"
]
]
dg' = updateGraph (compactSame . cf . collapseStructures') dg
rs = getRoots dg
ls = getLeaves dg
es = getWRoots dg
nAttr = entityAttributes rs ls es True Nothing
-- -----------------------------------------------------------------------------
drawModules :: String -> ModData -> DotGraph Node
drawModules gid dg = setID (Str gid)
$ graphvizClusters' dg
gAttrs
clusteredModule
cID
cAttr
nAttr
(const [])
where
cID s = bool (Just $ Str s) Nothing $ (not . null) s
gAttrs = [nodeAttrs] --[GraphAttrs [Label $ StrLabel t]]
cAttr p = [GraphAttrs [Label $ StrLabel p]]
rs = getRoots dg
ls = getLeaves dg
es = getWRoots dg
nAttr (n,m) = [ Label $ StrLabel m
, FillColor $ entCol rs ls es n
, Shape Tab
]