SourceGraph 0.5.5.0 → 0.6.0.0
raw patch · 18 files changed
+1255/−560 lines, 18 filesdep +mtldep ~Cabaldep ~Graphalyzedep ~graphviz
Dependencies added: mtl
Dependency ranges changed: Cabal, Graphalyze, graphviz, haskell-src-exts
Files
- Analyse.hs +67/−34
- Analyse/Colors.hs +65/−0
- Analyse/Everything.hs +53/−34
- Analyse/GraphRepr.hs +301/−0
- Analyse/Imports.hs +21/−17
- Analyse/Module.hs +41/−21
- Analyse/Utils.hs +29/−242
- Analyse/Visualise.hs +262/−0
- CabalInfo.hs +84/−0
- ChangeLog +18/−0
- KnownProblems.txt +0/−6
- Main.hs +23/−36
- Parsing/ParseModule.hs +62/−49
- Parsing/State.hs +26/−46
- Parsing/Types.hs +29/−18
- ParsingProblems.txt +0/−43
- SourceGraph.cabal +11/−8
- TODO +163/−6
Analyse.hs view
@@ -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
+ Analyse/Colors.hs view
@@ -0,0 +1,65 @@+{-+Copyright (C) 2010 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>++This file is part of SourceGraph.++SourceGraph is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 3 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- |+ Module : Analyse.Visualise+ Description : Visualisation functions.+ Copyright : (c) Ivan Lazar Miljenovic 2010+ License : GPL-3 or later.+ Maintainer : Ivan.Miljenovic@gmail.com++ Utility functions and types for analysis.+ -}+module Analyse.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
Analyse/Everything.hs view
@@ -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" -}
+ Analyse/GraphRepr.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE TypeFamilies+ , FlexibleContexts+ #-}++{-+Copyright (C) 2010 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>++This file is part of SourceGraph.++SourceGraph is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 3 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- |+ Module : Analyse.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+++-- -----------------------------------------------------------------------------+
Analyse/Imports.hs view
@@ -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
Analyse/Module.hs view
@@ -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]]
Analyse/Utils.hs view
@@ -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."+ ]
+ Analyse/Visualise.hs view
@@ -0,0 +1,262 @@+{-+Copyright (C) 2010 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com>++This file is part of SourceGraph.++SourceGraph is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 3 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{- |+ Module : Analyse.Visualise+ Description : Visualisation functions.+ Copyright : (c) Ivan Lazar Miljenovic 2010+ License : GPL-3 or later.+ Maintainer : Ivan.Miljenovic@gmail.com++ Utility functions and types for analysis.+ -}+module Analyse.Visualise where++import 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
+ CabalInfo.hs view
@@ -0,0 +1,84 @@+{-+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 : 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
ChangeLog view
@@ -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 ==================
− KnownProblems.txt
@@ -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.
Main.hs view
@@ -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."]
Parsing/ParseModule.hs view
@@ -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)
Parsing/State.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ {- Copyright (C) 2009 Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> @@ -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
Parsing/Types.hs view
@@ -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"
− ParsingProblems.txt
@@ -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.
SourceGraph.cabal view
@@ -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 }
TODO view
@@ -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/).