diff --git a/Analyse.hs b/Analyse.hs --- a/Analyse.hs +++ b/Analyse.hs @@ -32,7 +32,7 @@ import Analyse.Module import Analyse.Imports import Analyse.Everything -import Analyse.Utils +import Analyse.Colors import Parsing.Types import Data.Graph.Analysis hiding (Bold) @@ -59,36 +59,53 @@ , esData , esClass , esExp + , callCats ] -esCall, mods, esLoc, esData, esClass, esExp :: (DocGraph, DocInline) +esCall, mods, esLoc, esData, esClass, esExp, callCats :: (DocGraph, DocInline) -esCall = (dg', R.Bold $ Text "Two normal functions with a function call.") +esCall = (dg', R.Bold txt) where - dg' = ("legend_call", Text "Function Call", dg) + dg' = DG "legend_call" (Text "Function Call") dg dg = mkLegendGraph ns es - nAs = [Shape BoxShape, FillColor innerNode] - ns = [ (1, Label (StrLabel "f") : nAs) - , (2, Label (StrLabel "g") : nAs) + nAs = [Shape BoxShape, FillColor defaultNodeColor] + ns = [ (1, Label (StrLabel e1) : nAs) + , (2, Label (StrLabel e2) : nAs) ] - eAs = [Color [ColorName "black"]] + e1 = "f" + e2 = "g" + eAs = [Color [X11Color Black]] es = [(1,2,eAs)] + txt = Grouping [ Text "Two normal functions with" + , Emphasis $ Text e1 + , Text "calling" + , Emphasis $ Text e2 + , Text "." + ] -mods = (dg', R.Bold $ Text "Two normal modules with a module import.") +mods = (dg', R.Bold txt) where - dg' = ("legend_mods", Text "Module Import", dg) + dg' = DG "legend_mods" (Text "Module Import") dg dg = mkLegendGraph ns es - nAs = [Shape Tab, FillColor innerNode] - ns = [ (1, Label (StrLabel "Foo") : nAs) - , (2, Label (StrLabel "Bar") : nAs) + nAs = [Shape Tab, FillColor defaultNodeColor] + ns = [ (1, Label (StrLabel m1) : nAs) + , (2, Label (StrLabel m2) : nAs) ] + m1 = "Foo" + m2 = "Bar" es = [(1,2,[])] + txt = Grouping [ Text "Two modules with module" + , Emphasis $ Text m1 + , Text "importing" + , Emphasis $ Text m2 + , Text "." + ] esLoc = (dg', R.Bold $ Text "Entities from different modules.") where - dg' = ("legend_loc", Text "From module", dg) + dg' = DG "legend_loc" (Text "From module") dg dg = mkLegendGraph ns es - nAs = [FillColor innerNode] + nAs = [FillColor defaultNodeColor] ns = [ (1, Label (StrLabel "Current module") : Style [SItem Bold []] : nAs) , (2, Label (StrLabel "Other project module") @@ -102,21 +119,21 @@ esData = (dg', R.Bold $ Text "Data type declaration.") where - dg' = ("legend_data", Text "Data type declaration", dg) + dg' = DG "legend_data" (Text "Data type declaration") dg dg = mkLegendGraph ns es - nAs = [FillColor innerNode] + nAs = [FillColor defaultNodeColor] ns = [ (1, Label (StrLabel "Constructor") : Shape Box3D : nAs) , (2, Label (StrLabel "Record function") : Shape Component : nAs) ] - es = [(2,1,[ Color [ColorName "magenta"], ArrowTail oDot, ArrowHead vee])] + es = [(2,1,[ Color [X11Color Magenta], ArrowTail oDot, ArrowHead vee])] esClass = (dg', R.Bold $ Text "Class and instance declarations.") where - dg' = ("legend_class", Text "Class declaration", dg) + dg' = DG "legend_class" (Text "Class declaration") dg dg = mkLegendGraph ns es - nAs = [FillColor innerNode] + nAs = [FillColor defaultNodeColor] ns = [ (1, Label (StrLabel "Default instance") : Shape Octagon : nAs) , (2, Label (StrLabel "Class function") @@ -125,26 +142,42 @@ : Shape Octagon : nAs) ] eAs = [Dir NoDir] - es = [ (2,1, Color [ColorName "navy"] : eAs) - , (2,3, Color [ColorName "turquoise"] : eAs) + es = [ (2,1, Color [X11Color Navy] : eAs) + , (2,3, Color [X11Color Turquoise] : eAs) ] -esExp = (dg', R.Bold $ Text "Entity location classification.") +esExp = (dg', R.Bold $ Text "Entity location/accessibility classification.") where - dg' = ("legend_loc2", Text "Entity Location", dg) + dg' = DG "legend_loc2" (Text "Entity Location") dg dg = mkLegendGraph ns es - ns = [ (1, [ Label (StrLabel "Un-exported root entity") - , FillColor unExportedRoot]) - , (2, [ Label (StrLabel "Exported root entity") - , FillColor exportedRoot]) - , (3, [ Label (StrLabel "Exported non-root entity") - , FillColor exportedInner]) - , (4, [ Label (StrLabel "Leaf entity") - , FillColor leafNode]) - , (5, [ Label (StrLabel "Normal entity") - , FillColor innerNode]) + ns = zip [1..] + [ [ Label (StrLabel "Inaccessible entity") + , FillColor inaccessibleColor] + , [ Label (StrLabel "Exported root entity") + , FillColor exportedRootColor] + , [ Label (StrLabel "Exported non-root entity") + , FillColor exportedInnerColor] + , [ Label (StrLabel "Implicitly exported entity") + , FillColor implicitExportColor] + , [ Label (StrLabel "Leaf entity") + , FillColor leafColor] + , [ Label (StrLabel "Normal entity") + , FillColor defaultNodeColor] ] es = [] + +callCats = (dg', R.Bold $ Text "Edge classification.") + where + dg' = DG "legend_edges" (Text "Edge Classification") dg + dg = mkLegendGraph ns es + ns = map (flip (,) [Label (StrLabel ""), Shape PointShape]) [1..5] + eA = Dir NoDir + es = [ (1,2, [eA, Label (StrLabel "Clique"), Color [cliqueColor]]) + , (2,3, [eA, Label (StrLabel "Cycle"), Color [cycleColor]]) + , (3,4, [eA, Label (StrLabel "Chain"), Color [chainColor]]) + , (4,5, [eA, Label (StrLabel "Normal"), Color [defaultEdgeColor]]) + ] + mkLegendGraph :: [(Int,Attributes)] -> [(Int,Int,Attributes)] -> DotGraph Node diff --git a/Analyse/Colors.hs b/Analyse/Colors.hs new file mode 100644 --- /dev/null +++ b/Analyse/Colors.hs @@ -0,0 +1,65 @@ +{- +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.Colors where + +import Data.GraphViz.Attributes.Colors + +inaccessibleColor :: Color +inaccessibleColor = X11Color Crimson + +exportedRootColor :: Color +exportedRootColor = X11Color Gold + +exportedInnerColor :: Color +exportedInnerColor = X11Color Goldenrod + +implicitExportColor :: Color +implicitExportColor = X11Color Khaki + +leafColor :: Color +leafColor = X11Color Cyan + +defaultNodeColor :: Color +defaultNodeColor = X11Color Bisque + +defaultEdgeColor :: Color +defaultEdgeColor = X11Color Black + +cliqueColor :: Color +cliqueColor = X11Color Orange + +cycleColor :: Color +cycleColor = X11Color DarkOrchid + +chainColor :: Color +chainColor = X11Color Chartreuse + +clusterBackground :: Color +clusterBackground = X11Color Lavender diff --git a/Analyse/Everything.hs b/Analyse/Everything.hs --- a/Analyse/Everything.hs +++ b/Analyse/Everything.hs @@ -31,6 +31,8 @@ import Parsing.Types import Analyse.Utils +import Analyse.GraphRepr +import Analyse.Visualise import Data.Graph.Analysis @@ -42,6 +44,8 @@ import Text.Printf(printf) import System.Random(RandomGen) +-- ----------------------------------------------------------------------------- + -- | Performs analysis of the entire codebase. analyseEverything :: (RandomGen g) => g -> [ModName] -> ParsedModules -> DocElement @@ -53,6 +57,7 @@ , clustersOf g -- , collapseAnal , coreAnal + , levelAnal , cycleCompAnal , rootAnal , componentAnal @@ -62,8 +67,8 @@ ] -codeToGraph :: [ModName] -> ParsedModules -> HSData -codeToGraph exps pms = importData params +codeToGraph :: [ModName] -> ParsedModules -> HData' +codeToGraph exps pms = mkHData' vs $ importData params where pms' = M.elems pms exps' = S.toList . S.unions @@ -72,87 +77,91 @@ $ map internalEnts pms' calls = MS.toList . MS.map callToRel . MS.unions $ map funcCalls pms' + vs = S.filter (not . internalEntity) + . S.unions $ map virtualEnts pms' params = Params { dataPoints = ents , relationships = calls , roots = exps' , directed = True } -graphOf :: HSData -> Maybe DocElement +graphOf :: HData' -> Maybe DocElement graphOf cd = Just $ Section sec [gc] where sec = Text "Visualisation of the entire software" - gc = GraphImage ("code", Text lbl, drawGraph lbl Nothing cd) + gc = GraphImage $ DG "code" (Text lbl) (drawGraph lbl Nothing cd) lbl = "Entire Codebase" -clustersOf :: (RandomGen g) => g -> HSData -> Maybe DocElement +clustersOf :: (RandomGen g) => g -> HData' -> Maybe DocElement clustersOf g cd = Just $ Section sec [ text, gc, textAfter , blank, cwMsg, cw] -- , blank, rngMsg, rng] where blank = Paragraph [BlankSpace] sec = Text "Visualisation of overall function calls" - gc = GraphImage ("codeCluster", Text lbl, drawGraph' lbl cd) + gc = GraphImage $ DG "codeCluster" (Text lbl) (drawGraph' lbl cd) text = Paragraph [Text "Here is the current module grouping of functions:"] lbl = "Current module groupings" textAfter = Paragraph [Text "Here is a proposed alternate module grouping:"] -- [Text "Here are two proposed module groupings:"] cwMsg = Paragraph [Emphasis $ Text "Using the Chinese Whispers algorithm:"] - cw = GraphImage ("codeCW", Text cwLbl, drawClusters cwLbl (chineseWhispers g) cd) + cw = GraphImage $ DG "codeCW" (Text cwLbl) (drawClusters cwLbl (chineseWhispers g) cd) cwLbl = "Chinese Whispers module suggestions" {- rngMsg = Paragraph [Emphasis $ Text "Using the Relative Neighbourhood algorithm:"] - rng = GraphImage ("codeRNG", Text rngLbl, drawClusters lbl relNbrhd cd) + rng = GraphImage $ DG "codeRNG" (Text rngLbl) (drawClusters lbl relNbrhd cd) -- Being naughty to avoid having to define drawClusters' relNbrhd = relativeNeighbourhood $ directedData cd rngLbl = "Relative Neighbourhood module suggestions" -} -componentAnal :: HSData -> Maybe DocElement +componentAnal :: HData' -> Maybe DocElement componentAnal cd | single comp = Nothing | otherwise = Just $ Section sec [Paragraph [Text text]] where - comp = applyAlg componentsOf $ collapseStructures cd + -- Use compactData as the number of edges don't matter, just + -- whether or not an edge exists. + comp = applyAlg componentsOf . compactData $ collapsedHData cd len = length comp sec = Text "Function component analysis" text = printf "The functions are split up into %d components. \ \You may wish to consider splitting the code up \ \into multiple libraries." len -cliqueAnal :: HSData -> Maybe DocElement +cliqueAnal :: HData' -> Maybe DocElement cliqueAnal cd | null clqs = Nothing | otherwise = Just el where clqs = onlyCrossModule . applyAlg cliquesIn - . onlyNormalCalls $ collapseStructures cd + . onlyNormalCalls' . compactData $ collapsedHData cd clqs' = return . Itemized $ map (Paragraph . return . Text . showNodes' (fullName . snd)) clqs text = Text "The code has the following cross-module cliques:" el = Section sec $ Paragraph [text] : clqs' sec = Text "Overall clique analysis" -cycleAnal :: HSData -> Maybe DocElement +cycleAnal :: HData' -> Maybe DocElement cycleAnal cd | null cycs = Nothing | otherwise = Just el where cycs = onlyCrossModule . applyAlg uniqueCycles - . onlyNormalCalls $ collapseStructures cd + . onlyNormalCalls' . compactData $ collapsedHData cd cycs' = return . Itemized $ map (Paragraph . return . Text . showCycle' (fullName . snd)) cycs text = Text "The code has the following cross-module non-clique cycles:" el = Section sec $ Paragraph [text] : cycs' sec = Text "Overall cycle analysis" -chainAnal :: HSData -> Maybe DocElement +chainAnal :: HData' -> Maybe DocElement chainAnal cd | null chns = Nothing | otherwise = Just el where chns = onlyCrossModule . interiorChains - . onlyNormalCalls $ collapseStructures cd + . onlyNormalCalls' . compactData $ collapsedHData cd chns' = return . Itemized $ map (Paragraph . return . Text . showPath' (fullName . snd)) chns text = Text "The code has the following cross-module chains:" @@ -162,24 +171,25 @@ [Paragraph [text]] ++ chns' ++ [Paragraph [textAfter]] sec = Text "Overall chain analysis" -rootAnal :: HSData -> Maybe DocElement +rootAnal :: HData' -> Maybe DocElement rootAnal cd | asExpected = Nothing - | otherwise = Just $ Section sec unReachable + | otherwise = Just $ Section sec inaccessible where - (_, _, ntWd) = classifyRoots $ collapseStructures cd - ntWd' = map snd ntWd + cd' = compactData $ origHData cd + ntWd = S.toList . inaccessibleNodes $ addImplicit (origVirts cd) cd' + ntWd' = applyAlg getLabels cd' ntWd asExpected = null ntWd - unReachable = [ Paragraph [Text "These functions are those that are unreachable:"] + inaccessible = [ Paragraph [Text "These functions are those that are inaccessible:"] , Paragraph [Emphasis . Text $ showNodes' fullName ntWd'] ] sec = Text "Overall root analysis" -cycleCompAnal :: HSData -> Maybe DocElement +cycleCompAnal :: HData' -> Maybe DocElement cycleCompAnal cd = Just $ Section sec pars where - cc = cyclomaticComplexity $ collapseStructures cd + cc = cyclomaticComplexity . graphData $ collapsedHData cd sec = Text "Overall Cyclomatic Complexity" pars = [Paragraph [text], Paragraph [textAfter, link]] text = Text @@ -190,24 +200,33 @@ (Web "http://en.wikipedia.org/wiki/Cyclomatic_complexity") -coreAnal :: HSData -> Maybe DocElement -coreAnal cd = if isEmpty core - then Nothing - else Just $ Section sec [hdr, anal] +coreAnal :: HData' -> Maybe DocElement +coreAnal = fmap mkDE . makeCore where - cd' = updateGraph coreOf $ collapseStructures cd - core = graph cd' + mkDE cd' = Section sec [ hdr + , GraphImage $ DG "codeCore" + (Text lbl) + (drawGraph lbl Nothing cd') + ] lbl = "Overall core" - hdr = Paragraph [Text "The core of software can be thought of as \ - \the part where all the work is actually done."] - anal = GraphImage ("codeCore", Text lbl, drawGraph lbl Nothing cd') + hdr = coreDesc "software" sec = Text "Overall Core analysis" +levelAnal :: HData' -> Maybe DocElement +levelAnal cd = Just $ Section sec [hdr, lvls] + where + lvls = GraphImage $ DG p (Text lbl) (drawLevels lbl Nothing cd) + p = "code_levels" + lbl = unwords ["Levels within software"] + sec = Grouping [Text "Visualisation of levels in the software"] + hdr = Paragraph [Text "Visualises how far away from the exported root\ + \ entities an entity is."] + -- Comment out until can work out a way of dealing with [Entity] for -- the node-label type. {- -collapseAnal :: HSData -> Maybe DocElement +collapseAnal :: HData' -> Maybe DocElement collapseAnal cd = if (trivialCollapse gc) then Nothing else Just $ Section sec [hdr, gr] @@ -218,7 +237,7 @@ hdr = Paragraph [Text "The collapsed view of code collapses \ \down all cliques, cycles, chains, etc. to \ \make the graph tree-like." ] - gr = GraphImage ("codeCollapsed", Text lbl, drawGraph lbl Nothing cd') + gr = GraphImage $ DG "codeCollapsed" (Text lbl) (drawGraph lbl Nothing cd') sec = Text "Collapsed view of the entire codebase" -} diff --git a/Analyse/GraphRepr.hs b/Analyse/GraphRepr.hs new file mode 100644 --- /dev/null +++ b/Analyse/GraphRepr.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE TypeFamilies + , FlexibleContexts + #-} + +{- +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.GraphRepr + Description : Interacting with GraphData + Copyright : (c) Ivan Lazar Miljenovic 2009 + License : GPL-3 or later. + Maintainer : Ivan.Miljenovic@gmail.com + + Interacting with GraphData from Graphalyze. + -} +module Analyse.GraphRepr + ( -- * General stuff + GData(..) + , mapData + , mapData' + -- * Entity-based + , HData' + , mkHData' + , origHData + , origVirts + , collapsedHData + , collapsedVirts + , updateOrig + , updateCollapsed + , makeCore + , HData + , mkHData + , HSData + , HSClustData + , HSGraph + , HSClustGraph + -- ** Utility functions + , addImplicit + , implicitExports + , onlyNormalCalls + , onlyNormalCalls' + -- * Import-based + , MData + , mkMData + , ModData + , ModGraph + ) where + +import Parsing.Types +import Analyse.Utils +import Analyse.Colors + +import Data.Graph.Analysis +import Data.Graph.Inductive +import Data.GraphViz.Attributes.Colors(Color) + +import Data.List(isPrefixOf) +import Data.Maybe(mapMaybe) +import qualified Data.Map as M +import Data.Map(Map) +import qualified Data.Set as S +import Data.Set(Set) +import Control.Monad(liftM2) + +-- ----------------------------------------------------------------------------- + +data GData n e = GD { graphData :: GraphData n e + , compactData :: GraphData n (Int, e) + , nodeCols :: [(Set Node, Color)] + , edgeCols :: [(Set Edge, Color)] + } + +mkGData :: (Ord e) => (GraphData n e -> [(Set Node, Color)]) + -> (GraphData n e -> [(Set Edge, Color)]) + -> GraphData n e -> GData n e +mkGData n e g = GD { graphData = g + , compactData = updateGraph compactSame g + , nodeCols = n g + , edgeCols = e g + } + +-- | Does not touch the 'nodeCols' values. Should only touch the labels. +mapData :: (Ord e') => (GraphData n e -> GraphData n' e') + -> GData n e -> GData n' e' +mapData f gd = GD { graphData = gr' + , compactData = updateGraph compactSame gr' + , nodeCols = nodeCols gd + , edgeCols = edgeCols gd + } + where + gr = graphData gd + gr' = f gr + +mapData' :: (Ord e') => (AGr n e -> AGr n' e') -> GData n e -> GData n' e' +mapData' f = mapData (updateGraph f) + +commonColors :: GraphData n e -> [(Set Node, Color)] +commonColors gd = [ (rs', exportedRootColor) + , (es, exportedInnerColor) + , (ls, leafColor) + ] + where + rs' = S.intersection rs es + rs = getRoots gd + ls = getLeaves gd + es = getWRoots gd + +getRoots :: GraphData a b -> Set Node +getRoots = S.fromList . applyAlg rootsOf' + +getLeaves :: GraphData a b -> Set Node +getLeaves = S.fromList . applyAlg leavesOf' + +getWRoots :: GraphData a b -> Set Node +getWRoots = S.fromList . wantedRootNodes + +-- ----------------------------------------------------------------------------- + +data HData' = HD' { origHData :: HData + , origVirts :: Set Entity + , collapsedHData :: HData + , collapsedVirts :: Set Entity + } + +mkHData' :: Set Entity -> HSData -> HData' +mkHData' vs hs = HD' { origHData = mkHData vs hs + , origVirts = vs + , collapsedHData = mkHData vs' hs' + , collapsedVirts = vs' + } + where + (hs', repLookup) = collapseStructures hs + vs' = S.fromList + . mapMaybe (flip M.lookup repLookup) + $ S.toList vs + +-- | Doesn't touch origVirts +updateOrig :: (HSGraph -> HSGraph) -> HData' -> HData' +updateOrig f hd' = hd' { origHData = mapData' f $ origHData hd' } + +-- | Doesn't touch collapsedVirts +updateCollapsed :: (HSGraph -> HSGraph) -> HData' -> HData' +updateCollapsed f hd' = hd' { collapsedHData = mapData' f $ collapsedHData hd' } + +makeCore :: HData' -> Maybe HData' +makeCore hd = bool Nothing (Just hd') $ isInteresting hd' + where + isInteresting = not . applyAlg (liftM2 (||) isEmpty unChanged) + . graphData . origHData + unChanged = applyAlg equal $ graphData (origHData hd) + hd' = updateOrig coreOf hd + +type HData = GData Entity CallType + +mkHData :: Set Entity -> HSData -> HData +mkHData vs = mkGData (entColors vs) (callColors . onlyNormalCalls) + +type HSData = GraphData Entity CallType +type HSClustData = GraphData (GenCluster Entity) CallType +type HSGraph = AGr Entity CallType +type HSClustGraph = AGr (GenCluster Entity) CallType + +entColors :: Set Entity -> GraphData Entity e -> [(Set Node, Color)] +entColors vs hd = (us, inaccessibleColor) + : + commonColors hd + ++ + -- Do this after in case there's an implicit export + -- that is explicitly exported. + [ (imps, implicitExportColor) + ] + where + hd' = addImplicit vs hd + us = inaccessibleNodes hd' + imps = implicitExports vs hd + +callColors :: HSData -> [(Set Edge, Color)] +callColors hd = [ (cliqueEdges clqs, cliqueColor) + , (cycleEdges cycs, cycleColor) + , (chainEdges chns, chainColor) + ] + where + clqs = applyAlg cliquesIn' hd + cycs = applyAlg uniqueCycles' hd + chns = applyAlg chainsIn' hd + +-- ----------------------------------------------------------------------------- + +onlyNormalCalls :: HSData -> HSData +onlyNormalCalls = updateGraph go + where + go = elfilter isNormalCall + +onlyNormalCalls' :: GraphData Entity (Int, CallType) + -> GraphData Entity (Int, CallType) +onlyNormalCalls' = updateGraph go + where + go = elfilter (isNormalCall . snd) + +isImplicitExport :: Set Entity -> LNode Entity -> Bool +isImplicitExport vs = liftM2 (||) underscoredEntity (virtClass vs) . label + +-- | Various warnings about unused/unexported entities are suppressed +-- if they start with an underscore: +-- http://www.haskell.org/ghc/docs/latest/html/users_guide/options-sanity.html +underscoredEntity :: Entity -> Bool +underscoredEntity = isPrefixOf "_" . name + +virtClass :: Set Entity -> Entity -> Bool +virtClass vs e = case eType e of + ClassMethod{} -> isVirt + CollapsedClass{} -> isVirt + _ -> False + where + isVirt = e `S.member` vs + +addImplicit :: Set Entity -> GraphData Entity e -> GraphData Entity e +addImplicit vs = addRootsBy (isImplicitExport vs) + +implicitExports :: Set Entity -> GraphData Entity e -> Set Node +implicitExports vs = S.fromList + . map node + . applyAlg (filterNodes (const (isImplicitExport vs))) + +-- | Collapse items that must be kept together before clustering, etc. +-- Also updates wantedRootNodes. +collapseStructures :: HSData -> (HSData, Map Entity Entity) +collapseStructures = collapseAndUpdate' collapseFuncs + +collapseFuncs :: [HSGraph -> [(NGroup, Entity)]] +collapseFuncs = [ 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) + +-- ----------------------------------------------------------------------------- + +type MData = GData ModName () + +mkMData :: ModData -> MData +mkMData = mkGData modColors modEdgeColors + +type ModData = GraphData ModName () +type ModGraph = AGr ModName () + +modColors :: GraphData ModName e -> [(Set Node, Color)] +modColors gd = (us, inaccessibleColor) : commonColors gd + where + us = inaccessibleNodes gd + +modEdgeColors :: (Eq e) => GraphData ModName e -> [(Set Edge, Color)] +modEdgeColors gd = [ (cycleEdges cycs, cycleColor) + , (chainEdges chns, chainColor) + ] + where + cycs = applyAlg cyclesIn' gd + chns = applyAlg chainsIn' gd + + +-- ----------------------------------------------------------------------------- + diff --git a/Analyse/Imports.hs b/Analyse/Imports.hs --- a/Analyse/Imports.hs +++ b/Analyse/Imports.hs @@ -31,11 +31,14 @@ import Parsing.Types import Analyse.Utils +import Analyse.GraphRepr +import Analyse.Visualise import Data.Graph.Analysis import Data.Maybe(mapMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Text.Printf(printf) -- ----------------------------------------------------------------------------- @@ -55,8 +58,8 @@ , chainAnal ] -importsToGraph :: [ModName] -> ParsedModules -> ModData -importsToGraph exps pms = importData params +importsToGraph :: [ModName] -> ParsedModules -> MData +importsToGraph exps pms = mkMData $ importData params where params = Params { dataPoints = M.keys pms , relationships = moduleImports pms @@ -71,31 +74,31 @@ . M.keys $ imports pm toRel m m' = (m,m',()) -graphOf :: ModData -> Maybe DocElement +graphOf :: MData -> Maybe DocElement graphOf imd = Just $ Section sec [gi] where sec = Text "Visualisation of imports" - gi = GraphImage ("imports", Text lbl, drawModules lbl imd) + gi = GraphImage $ DG "imports" (Text lbl) (drawModules lbl imd) lbl = "Import visualisation" -componentAnal :: ModData -> Maybe DocElement +componentAnal :: MData -> Maybe DocElement componentAnal imd | single comp = Nothing | otherwise = Just el where - comp = applyAlg componentsOf imd + comp = applyAlg componentsOf $ graphData imd len = length comp el = Section sec [Paragraph [Text text]] sec = Text "Import component analysis" text = printf "The imports have %d components. \ \You may wish to consider splitting the code up." len -cycleAnal :: ModData -> Maybe DocElement +cycleAnal :: MData -> Maybe DocElement cycleAnal imd | null cycs = Nothing | otherwise = Just el where - cycs = applyAlg cyclesIn imd + cycs = applyAlg cyclesIn $ graphData imd cycs' = return . Itemized $ map (Paragraph . return . Text . showCycle' (nameOfModule' . snd)) cycs text = Text "The imports have the following cycles:" @@ -105,12 +108,12 @@ $ Paragraph [text] : cycs' ++ [Paragraph [textAfter]] sec = Text "Cycle analysis of imports" -chainAnal :: ModData -> Maybe DocElement +chainAnal :: MData -> Maybe DocElement chainAnal imd | null chns = Nothing | otherwise = Just el where - chns = interiorChains imd + chns = interiorChains $ graphData imd chns' = return . Itemized $ map (Paragraph . return . Text . showPath' (nameOfModule . snd)) chns text = Text "The imports have the following chains:" @@ -120,23 +123,24 @@ [Paragraph [text]] ++ chns' ++ [Paragraph [textAfter]] sec = Text "Import chain analysis" -rootAnal :: ModData -> Maybe DocElement +rootAnal :: MData -> Maybe DocElement rootAnal imd | asExpected = Nothing - | otherwise = Just $ Section sec unReachable + | otherwise = Just $ Section sec inaccessible where - (_, _, ntWd) = classifyRoots imd - ntWd' = map snd ntWd + imd' = graphData imd + ntWd = S.toList . inaccessibleNodes $ imd' + ntWd' = applyAlg getLabels imd' ntWd asExpected = null ntWd - unReachable = [ Paragraph [Text "These modules are those that are unreachable:"] + inaccessible = [ Paragraph [Text "These modules are those that are inaccessible:"] , Paragraph [Emphasis . Text $ showNodes' nameOfModule ntWd'] ] sec = Text "Import root analysis" -cycleCompAnal :: ModData -> Maybe DocElement +cycleCompAnal :: MData -> Maybe DocElement cycleCompAnal imd = Just $ Section sec pars where - cc = cyclomaticComplexity imd + cc = cyclomaticComplexity $ graphData imd sec = Text "Cyclomatic Complexity of imports" pars = [Paragraph [text], Paragraph [textAfter, link]] text = Text diff --git a/Analyse/Module.hs b/Analyse/Module.hs --- a/Analyse/Module.hs +++ b/Analyse/Module.hs @@ -31,6 +31,8 @@ import Parsing.Types import Analyse.Utils +import Analyse.GraphRepr +import Analyse.Visualise import Data.Graph.Analysis @@ -45,7 +47,7 @@ -- Helper types -- | Shorthand type -type ModuleData = (String, ModName, HSData) +type ModuleData = (String, ModName, HData') -- ----------------------------------------------------------------------------- @@ -66,6 +68,7 @@ elems = mapMaybe ($fd) [ graphOf -- , collapseAnal , coreAnal + , levelAnal , cycleCompAnal , rootAnal , componentAnal @@ -78,11 +81,12 @@ -- | Convert the module to the /Graphalyze/ format. moduleToGraph :: ParsedModule -> (Int,ModuleData) -moduleToGraph hm = (n,(nameOfModule mn, mn, fd)) +moduleToGraph hm = (n,(nameOfModule mn, mn, mkHData' vs fd)) where mn = moduleName hm n = applyAlg noNodes fd fd = importData params + vs = virtualEnts hm params = Params { dataPoints = S.toList $ internalEnts hm , relationships = MS.toList . MS.map callToRel $ funcCalls hm @@ -95,7 +99,7 @@ where sec = Grouping [ Text "Visualisation of" , Emphasis $ Text n] - gi = GraphImage (n, Text lbl, drawGraph lbl (Just m) fd) + gi = GraphImage $ DG n (Text lbl) (drawGraph lbl (Just m) fd) lbl = unwords ["Diagram of:", n] componentAnal :: ModuleData -> Maybe DocElement @@ -103,7 +107,9 @@ | single comp = Nothing | otherwise = Just el where - comp = applyAlg componentsOf $ collapseStructures fd + -- Use compactData as the number of edges don't matter, just + -- whether or not an edge exists. + comp = applyAlg componentsOf . compactData $ collapsedHData fd len = length comp el = Section sec [Paragraph [Text text]] sec = Grouping [ Text "Component analysis of" @@ -116,7 +122,8 @@ | null clqs = Nothing | otherwise = Just el where - clqs = applyAlg cliquesIn . onlyNormalCalls $ collapseStructures fd + clqs = applyAlg cliquesIn . onlyNormalCalls' . compactData + $ collapsedHData fd clqs' = return . Itemized $ map (Paragraph . return . Text . showNodes' (name . snd)) clqs text = Text $ printf "The module %s has the following cliques:" n @@ -129,7 +136,8 @@ | null cycs = Nothing | otherwise = Just el where - cycs = applyAlg uniqueCycles . onlyNormalCalls $ collapseStructures fd + cycs = applyAlg uniqueCycles . onlyNormalCalls' . compactData + $ collapsedHData fd cycs' = return . Itemized $ map (Paragraph . return . Text . showCycle' (name . snd)) cycs text = Text $ printf "The module %s has the following non-clique \ @@ -143,7 +151,8 @@ | null chns = Nothing | otherwise = Just el where - chns = interiorChains . onlyNormalCalls $ collapseStructures fd + chns = interiorChains . onlyNormalCalls' . compactData + $ collapsedHData fd chns' = return . Itemized $ map (Paragraph . return . Text . showPath' (name . snd)) chns text = Text $ printf "The module %s has the following chains:" n @@ -157,33 +166,44 @@ rootAnal :: ModuleData -> Maybe DocElement rootAnal (n,_,fd) | asExpected = Nothing - | otherwise = Just $ Section sec unReachable + | otherwise = Just $ Section sec inaccessible where - (_, _, ntWd) = classifyRoots $ collapseStructures fd - ntWd' = map snd ntWd + fd' = compactData $ origHData fd + ntWd = S.toList . inaccessibleNodes $ addImplicit (origVirts fd) fd' + ntWd' = applyAlg getLabels fd' ntWd asExpected = null ntWd - unReachable = [ Paragraph [Text "These functions are those that are unreachable:"] + inaccessible = [ Paragraph [Text "These functions are those that are inaccessible:"] , Paragraph [Emphasis . Text $ showNodes' name ntWd'] ] sec = Grouping [ Text "Root analysis of" , Emphasis (Text n)] coreAnal :: ModuleData -> Maybe DocElement -coreAnal (n,m,fd) = if isEmpty core - then Nothing - else Just el +coreAnal (n,m,fd) = fmap mkDE $ makeCore fd where - fd' = updateGraph coreOf $ collapseStructures fd - core = graph fd' + mkDE fd' = Section sec [ hdr + , GraphImage $ DG p + (Text lbl) + (drawGraph lbl (Just m) fd') + ] p = n ++ "_core" lbl = unwords ["Core of", n] - hdr = Paragraph [Text "The core of a module can be thought of as \ - \the part where all the work is actually done."] - anal = GraphImage (p,Text lbl,drawGraph lbl (Just m) fd') - el = Section sec [hdr, anal] + hdr = coreDesc "a module" sec = Grouping [ Text "Core analysis of" , Emphasis (Text n)] +levelAnal :: ModuleData -> Maybe DocElement +levelAnal (n,m,fd) = Just $ Section sec [hdr, lvls] + where + lvls = GraphImage $ DG p (Text lbl) (drawLevels lbl (Just m) fd) + p = n ++ "_levels" + lbl = unwords ["Levels within", n] + sec = Grouping [ Text "Visualisation of levels in" + , Emphasis (Text n) + ] + hdr = Paragraph [Text "Visualises how far away from the exported root\ + \ entities an entity is."] + -- Comment out until can work out a way of dealing with [Entity] for -- the node-label type. {- @@ -208,7 +228,7 @@ cycleCompAnal :: ModuleData -> Maybe DocElement cycleCompAnal (n,_,fd) = Just $ Section sec pars where - cc = cyclomaticComplexity $ collapseStructures fd + cc = cyclomaticComplexity . graphData $ collapsedHData fd sec = Grouping [ Text "Cyclomatic Complexity of" , Emphasis (Text n)] pars = [Paragraph [text], Paragraph [textAfter, link]] diff --git a/Analyse/Utils.hs b/Analyse/Utils.hs --- a/Analyse/Utils.hs +++ b/Analyse/Utils.hs @@ -29,28 +29,13 @@ -} 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 () +import qualified Data.Set as S +import Data.Set(Set) -- ----------------------------------------------------------------------------- @@ -62,243 +47,45 @@ 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 +bool f t b = if b then t else f -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 [] +chainEdges' :: NGroup -> Set Edge +chainEdges' [] = S.empty +chainEdges' ns = S.fromList $ zip ns (tail ns) -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 - ] +chainEdges :: [NGroup] -> Set Edge +chainEdges = S.unions . map chainEdges' -callAttributes' :: LEdge (Int, CallType) -> Attributes -callAttributes' (_,_,(n,ct)) = PenWidth (fromIntegral n) - : callAttributes ct +cycleEdges' :: NGroup -> Set Edge +cycleEdges' [] = S.empty +cycleEdges' [_] = S.empty +cycleEdges' ns@(n:ns') = (n, last ns') `S.insert` chainEdges' ns -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 ] +cycleEdges :: [NGroup] -> Set Edge +cycleEdges = S.unions . map cycleEdges' -clustAttributes' :: EntClustType -> [GlobalAttributes] -clustAttributes' = return . GraphAttrs . clustAttributes +cliqueEdges' :: NGroup -> Set Edge +cliqueEdges' ns = S.fromList [(f,t) | f <- ns, t <- ns, f /= t] -modClustAttrs :: ModName -> [GlobalAttributes] -modClustAttrs m = [GraphAttrs [ Label . StrLabel $ nameOfModule m - , Style [SItem Filled []] - , FillColor $ ColorName "lavender" - ] - ] +cliqueEdges :: [NGroup] -> Set Edge +cliqueEdges = S.unions . map cliqueEdges' -- ----------------------------------------------------------------------------- --- | 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 - --- ----------------------------------------------------------------------------- +-- For core -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 - ] +coreDesc :: String -> DocElement +coreDesc w = Paragraph [ Text "The core of" + , BlankSpace + , Text w + , BlankSpace + , Text "is calculated by recursively removing roots\ + \ and leaves of the call graph; as such, it\ + \ can be considered as the section where all\ + \ the \"real work\" is done." + ] diff --git a/Analyse/Visualise.hs b/Analyse/Visualise.hs new file mode 100644 --- /dev/null +++ b/Analyse/Visualise.hs @@ -0,0 +1,262 @@ +{- +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(defaultNodeColor, defaultEdgeColor, clusterBackground) + +import Data.Graph.Analysis hiding (Bold) +import Data.Graph.Inductive +import Data.GraphViz + +import Data.Maybe(isJust, maybe) +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 (Str gid) + $ graphvizClusters' (compactData dg') + gAttrs + toClust + ctypeID + clustAttributes' + nAttr + eAttr + where + dg' = origHData dg + gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + -- Possible clustering problem + toClust = clusterEntity -- bool clusterEntity clusterEntityM' $ isJust mm + nAttr = entityAttributes dg' (not $ isJust mm) mm + eAttr = callAttributes' dg' + +-- | One-module-per-cluster 'DotGraph'. +drawGraph' :: String -> HData' -> DotGraph Node +drawGraph' gid dg = setID (Str gid) + $ graphvizClusters (compactData dg') + gAttrs + modClustAttrs + nAttr + eAttr + where + dg' = collapsedHData dg + gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel 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)) + = [ Label $ StrLabel 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. + , Style [SItem 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 -> StyleItem +styleFor mm m@LocalMod{} = flip SItem [] . bool Solid Bold + $ maybe False ((==) m) mm +styleFor _ ExtMod{} = SItem Dashed [] +styleFor _ UnknownMod = SItem Dotted [] + +callAttributes :: GData n e -> Edge -> CallType + -> Attributes +callAttributes hd e NormalCall = [ Color [edgeCol hd e]] +callAttributes _ _ InstanceDeclaration = [ Color [X11Color Navy] + , Dir NoDir + ] +callAttributes _ _ DefaultInstDeclaration = [ Color [X11Color Turquoise] + , Dir NoDir + ] +callAttributes _ _ RecordConstructor = [ Color [X11Color Magenta] + , ArrowTail oDot + , ArrowHead vee + ] + +callAttributes' :: GData n e -> LEdge (Int, CallType) + -> Attributes +callAttributes' hd (f,t,(n,ct)) = PenWidth (fromIntegral n) + : callAttributes hd (f,t) ct + +clustAttributes :: EntClustType -> Attributes +clustAttributes (ClassDefn c) = [ Label . StrLabel $ "Class: " ++ c + , Style [SItem Filled [], SItem Rounded []] + , FillColor $ X11Color RosyBrown1 + ] +clustAttributes (DataDefn d) = [ Label . StrLabel $ "Data: " ++ d + , Style [SItem Filled [], SItem Rounded []] + , FillColor $ X11Color PapayaWhip + ] +clustAttributes (ClassInst _ d) = [ Label . StrLabel $ "Instance for: " ++ d + , Style [SItem Filled [], SItem Rounded []] + , FillColor $ X11Color SlateGray1 + ] +clustAttributes DefInst{} = [ Label . StrLabel $ "Default Instance" + , Style [SItem Filled [], SItem Rounded []] + , FillColor $ X11Color 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 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 (Str gid) + $ graphvizClusters (compactData dg') + gAttrs + (const cAttr) + nAttr + eAttr + where + dg' = mapData' cf $ collapsedHData dg + gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + cAttr = [GraphAttrs [ Style [SItem Filled []] + , FillColor clusterBackground + ] + ] + nAttr = entityAttributes dg' True Nothing + eAttr = callAttributes' dg' + +drawLevels :: String -> Maybe ModName -> HData' -> DotGraph Node +drawLevels gid mm hd = setID (Str gid) + $ graphvizClusters dg' + gAttrs + levelAttr + nAttr + eAttr + where + 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 [Label $ StrLabel t]] + nAttr = entityAttributes hd' (not $ isJust 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 [ Label (StrLabel t) + , Style [SItem Filled []] + , FillColor clusterBackground + ] + ] + +-- ----------------------------------------------------------------------------- +-- Dealing with inter-module imports, etc. + +drawModules :: String -> MData -> DotGraph Node +drawModules gid md = setID (Str gid) + $ graphvizClusters' (graphData md) + gAttrs + clusteredModule + cID + cAttr + nAttr + eAttr + where + cID (_,s) = bool Nothing (Just $ Str s) $ (not . null) s + gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] + cAttr dp = [GraphAttrs $ directoryAttributes dp] + nAttr (n,m) = [ Label $ StrLabel m + , FillColor $ entCol md n + , Shape Tab + ] + eAttr le = [Color [edgeCol md $ edge le]] + +directoryAttributes :: (Depth, String) -> Attributes +directoryAttributes (d,n) = Label (StrLabel n) : col + where + col = bool [] [Style [SItem Filled []], FillColor clusterBackground] + $ d `mod` 2 == 0 + +-- ----------------------------------------------------------------------------- + +entCol :: GData n e -> Node -> Color +entCol d n = maybe defaultNodeColor snd + . find hasNode + $ nodeCols d + where + hasNode = S.member n . fst + +nodeAttrs :: GlobalAttributes +nodeAttrs = NodeAttrs [ Margin . PVal $ PointD 0.4 0.1 + , Style [SItem Filled []] + ] + +edgeCol :: GData n e -> Edge -> Color +edgeCol d e = maybe defaultEdgeColor snd + . find hasEdge + $ edgeCols d + where + hasEdge = S.member e . fst diff --git a/CabalInfo.hs b/CabalInfo.hs new file mode 100644 --- /dev/null +++ b/CabalInfo.hs @@ -0,0 +1,84 @@ +{- +Copyright (C) 2009 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 : CabalInfo + Description : Obtain information from a .cabal file. + Copyright : (c) Ivan Lazar Miljenovic 2009 + License : GPL-3 or later. + Maintainer : Ivan.Miljenovic@gmail.com + + Used to parse and obtain information from the provided Cabal file. + -} +module CabalInfo(parseCabal) where + +import Distribution.Package +import Distribution.PackageDescription hiding (author) +import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.Configuration +import Distribution.Compiler(CompilerId) +import Distribution.ModuleName(toFilePath) +import Distribution.Verbosity(silent) +import Distribution.Simple.Compiler(compilerId) +import Distribution.Simple.GHC(configure) +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.System(buildPlatform) + +import Data.List(nub) +import Data.Maybe(isJust, fromJust) +import Control.Exception.Extensible(SomeException(..), try) +import Control.Monad(liftM) +import System.FilePath(dropExtension) + +-- ----------------------------------------------------------------------------- + +ghcID :: IO CompilerId +ghcID = liftM (compilerId . fst) + $ configure silent Nothing Nothing defaultProgramConfiguration + +parseCabal :: FilePath -> IO (Maybe (String, [FilePath])) +parseCabal fp = do cID <- ghcID + liftM (parseDesc cID) $ getDesc fp + where + -- Need to specify the Exception type + getDesc :: FilePath -> IO (Either SomeException GenericPackageDescription) + getDesc = try . readPackageDescription silent + parseDesc cID = fmap parse . compactEithers . fmap (unGeneric cID) + unGeneric cID = fmap fst + . finalizePackageDescription [] -- flags, use later + (const True) -- ignore + -- deps + buildPlatform + cID + [] + parse pd = (nm, exps) + where + nm = pName . pkgName $ package pd + pName (PackageName nm') = nm' + exes = executables pd + lib = library pd + moduleNames = map toFilePath + exps | not $ null exes = nub $ map (dropExtension . modulePath) exes + | isJust lib = moduleNames . exposedModules $ fromJust lib + | otherwise = error "No exposed modules" + +compactEithers :: Either a (Either b c) -> Maybe c +compactEithers (Right (Right c)) = Just c +compactEithers _ = Nothing diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +Changes in 0.6.0.0 +================== + +* Now supports "implicitly exported" entities (as requested by Curt + Sampson). This includes instantiated class methods from other + modules and functions, etc. that start with an underscore (see + http://www.haskell.org/ghc/docs/latest/html/users_guide/options-sanity.html + for more information). + +* All inaccessible entities are now reported, not just those that were + root nodes in the call graph. + +* Edges are now colour-coded based upon whether they are part of a + clique, cycle or a chain. + +* Level-based analyses: visualise how deep an entity is from those + exported entities. + Changes in 0.5.5.0 ================== diff --git a/KnownProblems.txt b/KnownProblems.txt deleted file mode 100644 --- a/KnownProblems.txt +++ /dev/null @@ -1,6 +0,0 @@ -This is a list of known problems with SourceGraph except for those -related to parsing. - -* Printing of labels doesn't always turn out so well (overlaps, etc.). - -* No options on what to do, etc. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -30,6 +30,7 @@ -} module Main where +import CabalInfo import Parsing import Parsing.Types(nameOfModule) import Analyse @@ -37,15 +38,8 @@ import Data.Graph.Analysis import Data.Graph.Analysis.Reporting.Pandoc -import Distribution.Package -import Distribution.PackageDescription hiding (author) -import Distribution.PackageDescription.Parse -import Distribution.ModuleName(toFilePath) -import Distribution.Verbosity - import Data.Char(toLower) -import Data.List(nub) -import Data.Maybe(isJust, fromJust, catMaybes) +import Data.Maybe(catMaybes) import qualified Data.Map as M import System.IO(hPutStrLn, stderr) import System.Directory( getCurrentDirectory @@ -53,13 +47,13 @@ , doesFileExist , getDirectoryContents) import System.FilePath( dropFileName - , dropExtension , takeExtension , isPathSeparator , () , (<.>)) import System.Random(newStdGen) import System.Environment(getArgs) +import Control.Arrow(second) import Control.Monad(liftM) import Control.Exception.Extensible(SomeException(..), try) @@ -97,7 +91,7 @@ \or a Haskell source file as an argument." return Nothing getPkgInfo [f] - | isCabalFile f = withF parseCabal + | isCabalFile f = withF parseCabal' | isHaskellFile f = withF parseMain where withF func = do ex <- doesFileExist f @@ -110,30 +104,8 @@ \or Haskell source file as an argument." return Nothing -parseCabal :: FilePath -> IO (Maybe (String, [ModName])) -parseCabal fp = do gpd <- try $ readPackageDescription silent fp - case gpd of - (Right gpd') -> return (Just $ parse gpd') - (Left SomeException{}) -> return Nothing - where - parse pd = (nm, exps') - where - cbl = packageDescription pd - nm = pName . pkgName $ package cbl - pName (PackageName nm') = nm' - cexes :: [Executable] - cexes = map (condTreeData .snd) $ condExecutables pd - exes = executables cbl - clib = condLibrary pd - lib = library cbl - moduleNames = map toFilePath - exps | not $ null cexes = nub $ map (dropExtension . modulePath) cexes - | not $ null exes = nub . map dropExtension . moduleNames $ exeModules cbl - | isJust clib = moduleNames . exposedModules . condTreeData - $ fromJust clib - | isJust lib = moduleNames . exposedModules $ fromJust lib - | otherwise = error "No exposed modules" - exps' = map fpToModule exps +parseCabal' :: FilePath -> IO (Maybe (String, [ModName])) +parseCabal' = liftM (fmap (second (map fpToModule))) . parseCabal isCabalFile :: FilePath -> Bool isCabalFile = hasExt "cabal" @@ -244,11 +216,12 @@ analyseCode fp nm exps hms = do d <- today g <- newStdGen let dc = doc d g - docOut <- createDocument pandocHtml dc + docOut <- createDocument pandocHtml' dc case docOut of Just path -> success path Nothing -> failure where + pandocHtml' = alsoSaveDot pandocHtml graphdir = "graphs" doc d g = Doc { rootDirectory = rt , fileFront = nm @@ -257,7 +230,7 @@ , author = a , date = d , legend = sgLegend - , content = msg : linkMsg : c g + , content = notes : c g } rt = fp programmeName sv s v = s ++ " (version " ++ v ++ ")" @@ -267,6 +240,7 @@ c g = analyse g exps hms success fp' = putStrLn $ unwords ["Report generated at:",fp'] failure = putErrLn "Unable to generate report" + notes = Section (Text "Notes") [msg, implicitMsg, linkMsg] msg = Paragraph [ Text "Please note that the source-code analysis in this\ \ document is not necessarily perfect: " , Emphasis $ Text programmeName @@ -275,5 +249,18 @@ , Text " a refactoring tool, and it's usage of Classes is\ \ still premature." ] + implicitMsg = Paragraph [ Text "Implicitly exported entities refer to\ + \ class methods that are instantiated\ + \ but defined elsewhere, or" + , BlankSpace + , DocLink (Text "entities whose names start with\ + \ an underscore") + (Web "http://www.haskell.org/ghc/docs/latest/html/users_guide/options-sanity.html") + , BlankSpace + , Text ". Note that even for " + , Emphasis $ Text "Main" + , BlankSpace + , Text "modules, these implicit exports are included." + ] linkMsg = Paragraph [Text "All graph visualisations link to larger \ \SVG versions of the same graph."] diff --git a/Parsing/ParseModule.hs b/Parsing/ParseModule.hs --- a/Parsing/ParseModule.hs +++ b/Parsing/ParseModule.hs @@ -70,8 +70,8 @@ instance ModuleItem Module where parseInfo (Module _ nm _ _ es is ds) = do let mn = createModule' nm - pm <- getParsedModule - putParsedModule $ pm { moduleName = mn } + pm <- get + put $ pm { moduleName = mn } parseInfo es parseInfo is parseInfo ds @@ -83,13 +83,13 @@ parseInfo iDcl = do mns <- getModuleNames ms <- getModules - pm <- getParsedModule + pm <- get let nm = getModName mns . nameOf $ importModule iDcl md = M.lookup nm ms es = imported nm md im = mi nm es pm' = pm { imports = M.insert nm im (imports pm) } - putParsedModule pm' + put pm' where mi nm es = I { fromModule = nm , importQuald = importQualified iDcl @@ -124,7 +124,7 @@ isDta = any (isUpper . head) cs' mkData c | isD c = Constructor n' | otherwise = RecordFunction n' -- Nothing - mkClass _ = ClassFunction n' + mkClass _ = ClassMethod n' eT = if isDta then mkData else mkClass createEnt _ _ = [] @@ -149,17 +149,17 @@ -- "main" defined, then it is defined as the export list (otherwise -- all top-level items are exported). instance ModuleItem (Maybe [ExportSpec]) where - parseInfo Nothing = do pm <- getParsedModule + parseInfo Nothing = do pm <- get fpm <- getFutureParsedModule el <- getLookup let mainFunc = M.lookup (Nothing,"main") el es = maybe (exportableEnts fpm) S.singleton mainFunc - putParsedModule $ pm { exports = es } - parseInfo (Just eps) = do pm <- getParsedModule + put $ pm { exports = es } + parseInfo (Just eps) = do pm <- get fpm <- getFutureParsedModule let el = exportableLookup fpm es = mkSet $ map (listedExp fpm el) eps - putParsedModule $ pm { exports = es } + put $ pm { exports = es } -- Doesn't work on re-exported Class/Data specs. listedExp :: ParsedModule -> EntityLookup @@ -196,18 +196,18 @@ parseInfo (DataDecl _ _ _ nm _ cs _) = do let d = nameOf nm els <- mapM (addConstructor d . unQConDecl) cs - pm <- getParsedModule + pm <- get let el = M.unions els dds' = M.insert d el $ dataDecls pm - putParsedModule $ pm { dataDecls = dds' } + put $ pm { dataDecls = dds' } -- GADT-style Data or Newtype parseInfo (GDataDecl _ _ _ n _ _ gds _) = do m <- getModuleName - pm <- getParsedModule + pm <- get let d = nameOf n el = addGConstructors m d gds dds' = M.insert d el $ dataDecls pm - putParsedModule $ pm { dataDecls = dds' } + put $ pm { dataDecls = dds' } -- Data Families: don't seem to have any entities parseInfo DataFamDecl{} = return () -- Type families are basically aliases... @@ -223,10 +223,10 @@ parseInfo (ClassDecl _ _ n _ _ cds) = do let c = nameOf n mels <- mapM (addClassDecl c) cds - pm <- getParsedModule + pm <- get let el = M.unions $ catMaybes mels cl' = M.insert c el $ classDecls pm - putParsedModule $ pm { classDecls = cl' } + put $ pm { classDecls = cl' } -- Instance of a class parseInfo (InstDecl _ _ n ts ids) = do let c = snd . fromJust $ qName n @@ -248,7 +248,7 @@ parseInfo pb@PatBind{} = do mn <- getModuleName el <- getLookup - pm <- getParsedModule + pm <- get (d,c) <- getDecl pb -- Might as well use this -- We can have more than one definition from here, unlike -- for Matches. @@ -262,7 +262,7 @@ pm' = pm { topEnts = topEnts pm `S.union` es , funcCalls = funcCalls pm `MS.union` cs } - putParsedModule pm' + put pm' -- The rest are foreign import/export and pragmas parseInfo _ = return () @@ -282,14 +282,14 @@ e = Ent m n' (Constructor d) return $ M.singleton (Nothing,n') e addConstructor d (RecDecl n rbs) = do m <- getModuleName - pm <- getParsedModule + pm <- get let n' = nameOf n ce = Ent m n' (Constructor d) rs = map nameOf $ concatMap fst rbs res = map (mkRe m) rs es = ce : res fcs = MS.fromList $ map (mkFc ce) res - putParsedModule $ addFcs pm fcs + put $ addFcs pm fcs return $ mkEl es where mkRe m r = Ent m r (RecordFunction d) @@ -315,19 +315,19 @@ addCDecl :: ClassName -> Decl -> PState (Maybe EntityLookup) addCDecl c (TypeSig _ ns _) = do m <- getModuleName let ns' = map nameOf ns - eTp = ClassFunction c + eTp = ClassMethod c es = map (\n -> Ent m n eTp) ns' return $ Just (mkEl es) addCDecl c (FunBind ms) = mapM_ (addCMatch c) ms >> return Nothing addCDecl c pb@PatBind{} = do mn <- getModuleName el <- getLookup - pm <- getParsedModule + pm <- get (d,cs) <- getDecl pb let vs = S.map snd d -- Class-based entities mkI n = Ent mn n (DefaultInstance c) - mkC n = Ent mn n (ClassFunction c) + mkC n = Ent mn n (ClassMethod c) cis = S.map (\n -> (mkC n, mkI n)) vs -- Instance Decls iDcls = S.map snd cis `S.union` instDecls pm @@ -345,7 +345,7 @@ `MS.union` ciCls `MS.union` cs' } - putParsedModule pm' + put pm' return Nothing -- Can't have anything else in classes addCDecl _ _ = return Nothing @@ -353,14 +353,14 @@ addCMatch :: ClassName -> Match -> PState () addCMatch c m = do el <- getLookup di <- addFuncCalls (DefaultInstance c) m - pm <- getParsedModule + pm <- get let cfn = name di cf = lookupEntity' el cfn dic = FC cf di DefaultInstDeclaration pm' = pm { instDecls = S.insert di $ instDecls pm , funcCalls = MS.insert dic $ funcCalls pm } - putParsedModule pm' + put pm' -- ----------------------------------------------------------------------------- -- Instance Declaration @@ -368,26 +368,27 @@ addInstDecl :: ClassName -> DataType -> InstDecl -> PState () addInstDecl c d (InsDecl decl) = do cs <- addIDecl c d decl mn <- getModuleName - pm <- getParsedModule + pm <- get let fromThisMod = (==) mn . inModule cs' = S.filter (not . fromThisMod) cs pm' = pm { virtualEnts = virtualEnts pm `S.union` cs' } - putParsedModule pm' + put pm' addInstDecl _ _ _ = return () addIDecl :: ClassName -> DataType -> Decl -> PState (Set Entity) addIDecl c d (FunBind ms) = liftM S.fromList $ mapM (addIMatch c d) ms addIDecl c d pb@PatBind{} = do mn <- getModuleName el <- getLookup - pm <- getParsedModule + pm <- get + pmf <- getFutureParsedModule (df,cs) <- getDecl pb let vs = S.map snd df -- Class-based entities mkI n = Ent mn n (ClassInstance c d) - mkC = classFuncLookup c el + mkC = classFuncLookup c pmf cis = S.map (\n -> (mkC n, mkI n)) vs -- Instance Decls iDcls = S.map snd cis `S.union` instDecls pm @@ -405,37 +406,49 @@ `MS.union` ciCls `MS.union` cs' } - putParsedModule pm' + put pm' return $ S.map fst cis addIDecl _ _ _ = return S.empty addIMatch :: ClassName -> DataType -> Match -> PState Entity -addIMatch c d m = do el <- getLookup +addIMatch c d m = do pmf <- getFutureParsedModule fi <- addFuncCalls (ClassInstance c d) m - pm <- getParsedModule + pm <- get let cfn = name fi - cf = classFuncLookup c el cfn + cf = classFuncLookup c pmf cfn ic = FC cf fi InstanceDeclaration pm' = pm { instDecls = S.insert fi $ instDecls pm , funcCalls = MS.insert ic $ funcCalls pm } - putParsedModule pm' + put pm' return cf -classFuncLookup :: ClassName -> EntityLookup -> EntityName -> Entity -classFuncLookup c el n = case inModule e of - UnknownMod -> e { eType = ClassFunction c } - _ -> e +-- Must use the future ParsedModule. Can't use internalLookup, since +-- it includes the virtuals and results in infinite loops as it tries +-- to lookup values that it creates... +-- +-- Note: we assume that if a class method is explicitly imported from +-- an external module, then it will be obvious that it is a class +-- method because otherwise the class won't be imported either. +classFuncLookup :: ClassName -> ParsedModule -> EntityName -> Entity +classFuncLookup c pmf n = case inModule e of + UnknownMod -> e { eType = ClassMethod c } + _ -> e where - e = lookupEntity' el n + e = lookupEntity' knownMethods n + knownMethods = localMethods `M.union` importMethods + localMethods = fromMaybe M.empty $ c `M.lookup` classDecls pmf + importMethods = M.filter (isMethod . eType) $ allImports pmf + isMethod (ClassMethod c') = c == c' + isMethod _ = False -- ----------------------------------------------------------------------------- -- For top-level functions addMatch :: Match -> PState () addMatch m = do e <- addFuncCalls NormalEntity m - pm <- getParsedModule - putParsedModule $ pm { topEnts = S.insert e $ topEnts pm } + pm <- get + put $ pm { topEnts = S.insert e $ topEnts pm } -- ----------------------------------------------------------------------------- @@ -444,16 +457,16 @@ addFuncCalls :: EntityType -> Match -> PState Entity addFuncCalls et m = do mn <- getModuleName el <- getLookup - pm <- getParsedModule + pm <- get (d,c) <- getMatch m let nm = snd $ S.findMin d - f = Ent { inModule = mn - , name = nm -- Assume non-qualified... - , eType = et + f = Ent { inModule = mn + , name = nm -- Assume non-qualified... + , eType = et } cs = MS.map (mkFC el f) c pm' = pm { funcCalls = cs `MS.union` funcCalls pm } - putParsedModule pm' + put pm' return f where mkFC el l qn = FC l (lookupEntity el qn) NormalCall @@ -617,9 +630,9 @@ $ mapM getQStmts qsss getExp (ExpTypeSig _ e _) = getExp e getExp (VarQuote qn) = return $ maybeEnt qn -getExp (Proc p e) = do (pd,pc) <- getPat p - c <- getExp e - return $ pc `MS.union` defElsewhere c pd +getExp (Proc _ p e) = do (pd,pc) <- getPat p + c <- getExp e + return $ pc `MS.union` defElsewhere c pd getExp (RightArrApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2) getExp (LeftArrApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2) getExp (RightArrHighApp e1 e2) = liftM2 MS.union (getExp e1) (getExp e2) diff --git a/Parsing/State.hs b/Parsing/State.hs --- a/Parsing/State.hs +++ b/Parsing/State.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {- Copyright (C) 2009 Ivan Lazar Miljenovic @@ -30,17 +32,19 @@ module Parsing.State ( PState , runPState + , get + , put , getModules , getModuleNames , getLookup - , getParsedModule , getFutureParsedModule , getModuleName - , putParsedModule ) where import Parsing.Types +import Control.Monad.RWS + -- ----------------------------------------------------------------------------- runPState :: ParsedModules -> ModuleNames @@ -49,61 +53,37 @@ where -- Tying the knot el = internalLookup pm' - mp = MP hms mns el pm pm' - pm' = parsedModule $ execState st mp - -data ModuleParsing = MP { moduleLookup :: ParsedModules - , modNmsLookup :: ModuleNames - , entityLookup :: EntityLookup - , parsedModule :: ParsedModule - , futureParsedModule :: ParsedModule - } + mp = MD hms mns el pm' + (pm', _) = execRWS (runPS st) mp pm -newtype PState value - = PS { runState :: ModuleParsing -> (value, ModuleParsing) } +data ModuleData = MD { moduleLookup :: ParsedModules + , modNmsLookup :: ModuleNames + , entityLookup :: EntityLookup + , futureParsedModule :: ParsedModule + } -instance Monad PState where - return v = PS (\ps -> (v,ps)) +type ModuleWrite = () - x >>= f = PS $ \ps -> let (r, ps') = runState x ps - in runState (f r) ps' +newtype PState value + = PS { runPS :: RWS ModuleData ModuleWrite ParsedModule value } + -- Note: don't derive MonadReader, etc. as don't want anything + -- outside this module to get the actual types used. + deriving (Monad, MonadState ParsedModule, MonadWriter ModuleWrite) +asks' :: (ModuleData -> a) -> PState a +asks' = PS . asks getModules :: PState ParsedModules -getModules = gets moduleLookup +getModules = asks' moduleLookup getModuleNames :: PState ModuleNames -getModuleNames = gets modNmsLookup +getModuleNames = asks' modNmsLookup getLookup :: PState EntityLookup -getLookup = gets entityLookup - -getParsedModule :: PState ParsedModule -getParsedModule = gets parsedModule +getLookup = asks' entityLookup getFutureParsedModule :: PState ParsedModule -getFutureParsedModule = gets futureParsedModule +getFutureParsedModule = asks' futureParsedModule getModuleName :: PState ModName -getModuleName = gets (moduleName . parsedModule) - -putParsedModule :: ParsedModule -> PState () -putParsedModule pm = modify (\ s -> s { parsedModule = pm } ) - - -get :: PState ModuleParsing -get = PS (\s -> (s,s)) - -put :: ModuleParsing -> PState () -put s = PS (const ((), s)) - -execState :: PState value -> ModuleParsing -> ModuleParsing -execState s = snd . runState s - -modify :: (ModuleParsing -> ModuleParsing) -> PState () -modify f = do s <- get - put (f s) - -gets :: (ModuleParsing -> value) -> PState value -gets f = do s <- get - return (f s) +getModuleName = gets moduleName diff --git a/Parsing/Types.hs b/Parsing/Types.hs --- a/Parsing/Types.hs +++ b/Parsing/Types.hs @@ -96,10 +96,11 @@ -- | The 'EntityLookup' for use within a module; combines imports with -- what is defined in the module. internalLookup :: ParsedModule -> EntityLookup -internalLookup pm = M.union imported internal +internalLookup pm = M.unions [imported, internal, virtuals] where - imported = importsLookup . M.elems $ imports pm + imported = allImports pm internal = exportableLookup pm + virtuals = mkLookup' $ virtualEnts pm -- | The defined stand-alone 'Entity's from this module. exportableLookup :: ParsedModule -> EntityLookup @@ -188,12 +189,19 @@ | UnknownMod deriving (Eq, Ord, Show, Read) -clusteredModule :: LNode ModName -> NodeCluster String String -clusteredModule (n,m) = go $ modulePathOf m +internalEntity :: Entity -> Bool +internalEntity e = case inModule e of + LocalMod{} -> True + _ -> False + +type Depth = Int + +clusteredModule :: LNode ModName -> NodeCluster (Depth, String) String +clusteredModule (n,m) = go 0 $ modulePathOf m where - go [m'] = N (n,m') - go (p:ps) = C p $ go ps - go [] = error "Shouldn't be able to have an empty module name." + go _ [m'] = N (n,m') + go d (p:ps) = C (d,p) $ go (succ d) ps + go _ [] = error "Shouldn't be able to have an empty module name." instance ClusterType ModName where clusterID = Just . Str . unDotPath . nameOfModule @@ -257,6 +265,9 @@ importsLookup :: [ModImport] -> EntityLookup importsLookup = M.unions . map importLookup +allImports :: ParsedModule -> EntityLookup +allImports = importsLookup . M.elems . imports + importLookup :: ModImport -> EntityLookup importLookup hi | importQuald hi = with @@ -270,9 +281,9 @@ -- ----------------------------------------------------------------------------- -data Entity = Ent { inModule :: ModName - , name :: EntityName - , eType :: EntityType +data Entity = Ent { inModule :: ModName + , name :: EntityName + , eType :: EntityType } deriving (Eq, Ord, Show, Read) @@ -301,7 +312,7 @@ setClust = case eType e of (Constructor d) -> C $ DataDefn d (RecordFunction d) -> C $ DataDefn d - (ClassFunction c) -> C $ ClassDefn c + (ClassMethod c) -> C $ ClassDefn c (DefaultInstance c) -> C (ClassDefn c) . C (DefInst c) (ClassInstance c d) -> C (ClassDefn c) . C (ClassInst c d) _ -> id @@ -359,9 +370,9 @@ fullName e = nameOfModule (inModule e) ++ moduleSep : name e defEntity :: EntityName -> Entity -defEntity nm = Ent { inModule = UnknownMod - , name = nm - , eType = NormalEntity +defEntity nm = Ent { inModule = UnknownMod + , name = nm + , eType = NormalEntity } setEntModule :: ModName -> Entity -> Entity @@ -405,7 +416,7 @@ | RecordFunction DataType -- (Maybe EntityName) -- same record function in -- multiple constructors - | ClassFunction ClassName + | ClassMethod ClassName | DefaultInstance ClassName | ClassInstance ClassName DataType -- The following three are only for when collapsing. @@ -426,12 +437,12 @@ getDataType _ = error "Should not see this" isClass :: EntityType -> Bool -isClass ClassFunction{} = True +isClass ClassMethod{} = True isClass DefaultInstance{} = True isClass _ = False -getClassName :: EntityType -> ClassName -getClassName (ClassFunction c) = c +getClassName :: EntityType -> ClassName +getClassName (ClassMethod c) = c getClassName (DefaultInstance c) = c getClassName _ = error "Should not see this" diff --git a/ParsingProblems.txt b/ParsingProblems.txt deleted file mode 100644 --- a/ParsingProblems.txt +++ /dev/null @@ -1,43 +0,0 @@ -Can't parse/understand the following types items: - -* Code that doesn't compile/type-check/etc.; haskell-src-exts won't understand - them. - -* Modules using CPP. - -* HaRP usage. - -* Template Haskell - -* Haskell Source with XML/Haskell Server Pages-style embedded XML - -* Data Family instances (both normal and GADT) don't have their - constructors/records added as it isn't obvious how to go from the - type to a name of the type. - -* FFI imports/exports are ignored. - -* Pragmas are ignored. - -Possible parsing problems with the following items: - -* Modules not within the given project; if an explicit import is used, - then the entitys are guessed at (can't always categorise function - types, etc.). - -* When using record puns, it is not always possible to distinguish - between the records and punned values. - -* When using record wildcards, not all records are completely - listed/used as both record functions and variables (see the problem - with record puns above). - -* When considering instances of a class, it doesn't deal well with - multi-param type classes, etc. in that it assumes the first type - mentioned is the type that the instance is for. This is mainly for - creating virtual functions for the instances. - -* Language options specified in the Cabal file. - -* If a datatype or class is re-exported from another module, then this - won't be picked up. diff --git a/SourceGraph.cabal b/SourceGraph.cabal --- a/SourceGraph.cabal +++ b/SourceGraph.cabal @@ -1,5 +1,5 @@ Name: SourceGraph -Version: 0.5.5.0 +Version: 0.6.0.0 Synopsis: Static code analysis using graph-theoretic techniques. Description: { Statically analyse Haskell source code using graph-theoretic @@ -41,8 +41,6 @@ Build-Type: Simple Extra-Source-Files: TODO ChangeLog - KnownProblems.txt - ParsingProblems.txt Source-Repository head Type: darcs @@ -52,12 +50,16 @@ Executable SourceGraph { Main-Is: Main.hs - Other-Modules: Parsing, + Other-Modules: CabalInfo, + Parsing, Parsing.ParseModule, Parsing.State, Parsing.Types, Analyse, Analyse.Utils, + Analyse.Colors, + Analyse.GraphRepr, + Analyse.Visualise, Analyse.Module, Analyse.Imports, Analyse.Everything, @@ -72,9 +74,10 @@ filepath, random, directory, + mtl, fgl, - Graphalyze >= 0.8.0.0 && < 0.9.0.0, - graphviz >= 2999.6.0.0 && < 2999.7.0.0, - Cabal >= 1.6 && < 1.7, - haskell-src-exts >= 1.1.0 && < 1.2.0 + Graphalyze >= 0.9.0.0 && < 0.10.0.0, + graphviz >= 2999.8.0.0 && < 2999.9.0.0, + Cabal >= 1.8 && < 1.9, + haskell-src-exts >= 1.5.0 && < 1.6.0 } diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,13 +1,170 @@ TODO for SourceGraph ==================== -* Let users choose output directory +This is the list of planned improvements to the SourceGraph program. +Please note that some of these improvements will actually take place +in the [Graphalyze](http://hackage.haskell.org/package/Graphalyze) +library. -* Let users choose output format +Parsing Improvements +-------------------- -* Have a "just draw the graph" option +SourceGraph uses +[haskell-src-exts](http://hackage.haskell.org/package/haskell-src-exts) +to parse Haskell code. As such, it is limited in terms of what it can +parse first of all by what haskell-src-exts supports. -* "Smarter" analysis: don't show compressed if its boring, etc. - -- Mainly done, could possibly be smarter +* The following types of items are not yet recognised; either add + support for them (e.g. using cpphs for CPP) or else log a message if + there is no sane way of integrating them into the call graph: -* Write a README + - Invalid code (these files will not even be readable by + haskell-src-exts and as such a warning should be displayed). + + - Modules using the C Pre-Processor; adding support for this will + depend on better Cabal file support and command line options. + + - [Haskell Regular + Patterns](http://hackage.haskell.org/package/harp), [Haskell + Source with XML](http://hackage.haskell.org/package/hsx) and the + embedded XML syntax of [Haskell Server + Pages](http://hackage.haskell.org/package/hsp) all utilise + haskell-src-exts to extend Haskell syntax; as such, the parsing + support is available but it is unknown how to convert them to + entities in the call graph. + + - It is unknown how to add [Data + Family](http://www.haskell.org/haskellwiki/GHC/Type_families) + instances (both normal and GADT style) into the call graph. + + - It is probably not possible to integrate [Foreign Function + Interface](http://www.haskell.org/haskellwiki/FFI) imports and + exports into the call graph. + + - [Template + Haskell](http://www.haskell.org/haskellwiki/Template_Haskell) is + also not currently supported. + +* The following items have partial/incomplete/possibly wrong support + for integration into the call graph: + + - Currently pragmas, LANGUAGE options, etc. are only supported if + they are included in the top level of the module (as such, + haskell-src-exts will use them for parsing purposes). + + - Entities explicitly imported from an external module are not + always correctly categorised; to improve support for this, any + class methods or datatype constructors/record functions should + be explicitly imported [rather than using the `Foo(..)`] syntax; + furthermore, a datatype import is only recognised as such if at + least one constructor is imported (otherwise it is assumed to be + a class). + + - When using record puns, it is not always possible to distinguish + between the records and punned values. + + - When using record wildcards, not all records are completely + listed/used as both record functions and variables (see the + problem with record puns above). + + - Multi-param type classes may not be considered/formatted + correctly. + + - Entities that are imported into a module and then re-exported + (including re-exporting the entire imported module) may not be + considered correctly. + + +Analysis Improvements +--------------------- + +* When considering levels, produce a plot of level size vs depth. + + - Similar plots may be useful for other analyses, such as the number + of cycles of a given size. + + - Possibly also provide a characterisation of the "shape" of the plot. + +* Provide comparisons from other large-scale Haskell projects for + analyses such as shape of the level graph, cyclomatic complexity. + + - To achieve this, possibly run a cut-down version of SourceGraph + over all packages in + [HackageDB](http://hackage.haskell.org/package/) to accumulate the + comparison information. + +* Include more ways of analysing software from its Call Graph. + +Reporting Format +---------------- + +* Use CSS, etc. to improve the generated HTML files. + +* Produce multi-page HTML documents. + +* Improve formatting of entity listing (listing of cliques, etc.). + +* Report errors/warnings (from parsing, etc.). + +* Improve graph visualisation: + + - Having a lot of edges makes it difficult to "read" the + visualisation (maybe when clustering have the edges go from + cluster to cluster?). + + - Ensure node labels do not extend past the boundary of the node + (note: for cluster labels, this seems to be a bug with Graphviz's + SVG output). + +Project Integration +------------------- + +* Allow clearer differentiation between Cabal-based and source-based + projects. + + - When basing it off files, allow the user to specify several files. + +* For Cabal: + + - When using Cabal, provide some way to choose which section is + being analysed (i.e. library or an executable). + + Probably also some way of reporting to the user which options are + available. + + - Pass GHC, CPP, etc. flags through for when parsing the files. + +Program Usage +------------- + +* Provide command-line options to allow users to set the following: + + - Output directory. + + - Report format. + + - What output to generate, e.g.: + + Brief analysis summary. + + Only produce a call-graph (overall, imports and per-module). + + - What to analyse, that is one of the following: + + Only one module (not when using Cabal mode). + + Only files used in that project. + + All files found (whether they are used in the project or not). + +* The ability to specify project flags (Cabal flags, CPP flags, etc.). + +* Write a README and supporting documentation. + +Future Plans +------------ + +* Write a proper website for SourceGraph. + +* Provide some way of making the analyses "interactive" (e.g. zooming, + slicing, etc.). + + - Noam Lewis' proposed interactive graph editor may be a start + towards providing this kind of functionality. + +* Integrate SourceGraph into + [HackageDB](http://hackage.haskell.org/package/).