SourceGraph 0.5.2.0 → 0.5.5.0
raw patch · 12 files changed
+246/−134 lines, 12 filesdep ~Graphalyze
Dependency ranges changed: Graphalyze
Files
- Analyse.hs +128/−2
- Analyse/Everything.hs +14/−18
- Analyse/Imports.hs +7/−14
- Analyse/Module.hs +10/−18
- Analyse/Utils.hs +53/−53
- ChangeLog +17/−6
- KnownProblems.txt +0/−8
- Main.hs +5/−2
- Parsing/ParseModule.hs +2/−2
- Parsing/Types.hs +4/−0
- SourceGraph.cabal +6/−5
- TODO +0/−6
Analyse.hs view
@@ -27,14 +27,18 @@ Analyse Haskell software -}-module Analyse where+module Analyse(analyse, sgLegend) where import Analyse.Module import Analyse.Imports import Analyse.Everything+import Analyse.Utils import Parsing.Types -import Data.Graph.Analysis+import Data.Graph.Analysis hiding (Bold)+import qualified Data.Graph.Analysis.Reporting as R (DocInline(Bold))+import Data.GraphViz.Types+import Data.GraphViz.Attributes import System.Random(RandomGen) @@ -47,3 +51,125 @@ , analyseImports exps hms , analyseModules hms ]++sgLegend :: [(DocGraph, DocInline)]+sgLegend = [ esCall+ , mods+ , esLoc+ , esData+ , esClass+ , esExp+ ]++esCall, mods, esLoc, esData, esClass, esExp :: (DocGraph, DocInline)++esCall = (dg', R.Bold $ Text "Two normal functions with a function call.")+ where+ 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)+ ]+ eAs = [Color [ColorName "black"]]+ es = [(1,2,eAs)]++mods = (dg', R.Bold $ Text "Two normal modules with a module import.")+ where+ 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)+ ]+ es = [(1,2,[])]++esLoc = (dg', R.Bold $ Text "Entities from different modules.")+ where+ dg' = ("legend_loc", Text "From module", dg)+ dg = mkLegendGraph ns es+ nAs = [FillColor innerNode]+ ns = [ (1, Label (StrLabel "Current module")+ : Style [SItem Bold []] : nAs)+ , (2, Label (StrLabel "Other project module")+ : Style [SItem Solid []] : nAs)+ , (3, Label (StrLabel "Known external module")+ : Style [SItem Dashed []] : nAs)+ , (4, Label (StrLabel "Unknown external module")+ : Style [SItem Dotted []] : nAs)+ ]+ es = []++esData = (dg', R.Bold $ Text "Data type declaration.")+ where+ dg' = ("legend_data", Text "Data type declaration", dg)+ dg = mkLegendGraph ns es+ nAs = [FillColor innerNode]+ 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])]++esClass = (dg', R.Bold $ Text "Class and instance declarations.")+ where+ dg' = ("legend_class", Text "Class declaration", dg)+ dg = mkLegendGraph ns es+ nAs = [FillColor innerNode]+ ns = [ (1, Label (StrLabel "Default instance")+ : Shape Octagon : nAs)+ , (2, Label (StrLabel "Class function")+ : Shape DoubleOctagon : nAs)+ , (3, Label (StrLabel "Instance for data type")+ : Shape Octagon : nAs)+ ]+ eAs = [Dir NoDir]+ es = [ (2,1, Color [ColorName "navy"] : eAs)+ , (2,3, Color [ColorName "turquoise"] : eAs)+ ]++esExp = (dg', R.Bold $ Text "Entity location classification.")+ where+ 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])+ ]+ es = []++mkLegendGraph :: [(Int,Attributes)] -> [(Int,Int,Attributes)]+ -> DotGraph Node+mkLegendGraph ns es = DotGraph { strictGraph = False+ , directedGraph = True+ , graphID = Nothing+ , graphStatements+ = DotStmts { attrStmts = atts+ , subGraphs = [nSG]+ , nodeStmts = []+ , edgeStmts = map mkE es+ }+ }+ where+ atts = [ GraphAttrs [OutputOrder EdgesFirst]+ , NodeAttrs [FontSize 10, Style [SItem Filled []]]+ ]+ sgAtts = [GraphAttrs [Rank MinRank]]+ nSG = DotSG { isCluster = False+ , subGraphID = Nothing+ , subGraphStmts = DotStmts { attrStmts = sgAtts+ , subGraphs = []+ , nodeStmts = map mkN ns+ , edgeStmts = []+ }+ }+ mkN (n,as) = DotNode n as+ mkE (f,t,as) = DotEdge f t True as
Analyse/Everything.hs view
@@ -125,7 +125,8 @@ | null clqs = Nothing | otherwise = Just el where- clqs = onlyCrossModule . applyAlg cliquesIn $ collapseStructures cd+ clqs = onlyCrossModule . applyAlg cliquesIn+ . onlyNormalCalls $ collapseStructures cd clqs' = return . Itemized $ map (Paragraph . return . Text . showNodes' (fullName . snd)) clqs text = Text "The code has the following cross-module cliques:"@@ -137,7 +138,8 @@ | null cycs = Nothing | otherwise = Just el where- cycs = onlyCrossModule . applyAlg uniqueCycles $ collapseStructures cd+ cycs = onlyCrossModule . applyAlg uniqueCycles+ . onlyNormalCalls $ collapseStructures cd cycs' = return . Itemized $ map (Paragraph . return . Text . showCycle' (fullName . snd)) cycs text = Text "The code has the following cross-module non-clique cycles:"@@ -149,7 +151,8 @@ | null chns = Nothing | otherwise = Just el where- chns = onlyCrossModule . interiorChains $ collapseStructures cd+ chns = onlyCrossModule . interiorChains+ . onlyNormalCalls $ collapseStructures cd chns' = return . Itemized $ map (Paragraph . return . Text . showPath' (fullName . snd)) chns text = Text "The code has the following cross-module chains:"@@ -162,22 +165,15 @@ rootAnal :: HSData -> Maybe DocElement rootAnal cd | asExpected = Nothing- | otherwise = Just $ Section sec ps+ | otherwise = Just $ Section sec unReachable where- (wntd, ntRs, ntWd) = classifyRoots cd- asExpected = null ntRs && null ntWd- rpt (s,ns) = if null ns- then Nothing- else Just [ Paragraph- [Text- $ concat ["These functions are those that are "- , s, ":"]]- , Paragraph [Emphasis . Text . showNodes' fullName $ map snd ns]]- ps = concat- $ mapMaybe rpt [ ("available for use and roots",wntd)- , ("available for use but not roots",ntRs)- , ("not available for use but roots",ntWd)]- sec = Text "Import root analysis"+ (_, _, ntWd) = classifyRoots $ collapseStructures cd+ ntWd' = map snd ntWd+ asExpected = null ntWd+ unReachable = [ Paragraph [Text "These functions are those that are unreachable:"]+ , Paragraph [Emphasis . Text $ showNodes' fullName ntWd']+ ]+ sec = Text "Overall root analysis" cycleCompAnal :: HSData -> Maybe DocElement
Analyse/Imports.hs view
@@ -123,21 +123,14 @@ rootAnal :: ModData -> Maybe DocElement rootAnal imd | asExpected = Nothing- | otherwise = Just $ Section sec ps+ | otherwise = Just $ Section sec unReachable where- (wntd, ntRs, ntWd) = classifyRoots imd- asExpected = null ntRs && null ntWd- rpt (s,ns) = if null ns- then Nothing- else Just [ Paragraph- [Text- $ concat ["These modules are those that are "- , s, ":"]]- , Paragraph [Emphasis . Text . showNodes' nameOfModule $ map snd ns]]- ps = concat- $ mapMaybe rpt [ ("in the export list and roots",wntd)- , ("in the export list but not roots",ntRs)- , ("not in the export list but roots",ntWd)]+ (_, _, ntWd) = classifyRoots imd+ ntWd' = map snd ntWd+ asExpected = null ntWd+ unReachable = [ Paragraph [Text "These modules are those that are unreachable:"]+ , Paragraph [Emphasis . Text $ showNodes' nameOfModule ntWd']+ ] sec = Text "Import root analysis" cycleCompAnal :: ModData -> Maybe DocElement
Analyse/Module.hs view
@@ -116,7 +116,7 @@ | null clqs = Nothing | otherwise = Just el where- clqs = applyAlg cliquesIn $ collapseStructures fd+ clqs = applyAlg cliquesIn . onlyNormalCalls $ collapseStructures 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 +129,7 @@ | null cycs = Nothing | otherwise = Just el where- cycs = applyAlg uniqueCycles $ collapseStructures fd+ cycs = applyAlg uniqueCycles . onlyNormalCalls $ collapseStructures 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 +143,7 @@ | null chns = Nothing | otherwise = Just el where- chns = interiorChains $ collapseStructures fd+ chns = interiorChains . onlyNormalCalls $ collapseStructures fd chns' = return . Itemized $ map (Paragraph . return . Text . showPath' (name . snd)) chns text = Text $ printf "The module %s has the following chains:" n@@ -157,22 +157,14 @@ rootAnal :: ModuleData -> Maybe DocElement rootAnal (n,_,fd) | asExpected = Nothing- | otherwise = Just el+ | otherwise = Just $ Section sec unReachable where- (wntd, ntRs, ntWd) = classifyRoots $ collapseStructures fd- asExpected = null ntRs && null ntWd- rpt (s,ns) = if null ns- then Nothing- else Just [ Paragraph- [Text- $ concat ["These nodes are those that are "- , s, ":"]]- , Paragraph [Emphasis . Text . showNodes' name $ map snd ns]]- ps = concat- $ mapMaybe rpt [ ("in the export list and roots",wntd)- , ("in the export list but not roots",ntRs)- , ("not in the export list but roots",ntWd)]- el = Section sec ps+ (_, _, ntWd) = classifyRoots $ collapseStructures fd+ ntWd' = map snd ntWd+ asExpected = null ntWd+ unReachable = [ Paragraph [Text "These functions are those that are unreachable:"]+ , Paragraph [Emphasis . Text $ showNodes' name ntWd']+ ] sec = Grouping [ Text "Root analysis of" , Emphasis (Text n)]
Analyse/Utils.hs view
@@ -37,10 +37,8 @@ import Data.GraphViz import Data.List(groupBy, sortBy)--- import Data.Maybe(isJust)+import Data.Maybe(isJust) import Data.Function(on)-import qualified Data.Set as S-import Data.Set(Set) import qualified Data.IntSet as I import Data.IntSet(IntSet) @@ -79,7 +77,7 @@ 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 ++ "\\nData: " ++ d)+ mkInst m (c,d) = Ent m ("Class: " ++ c ++ ", Data: " ++ d) (CollapsedInstance c d) @@ -97,21 +95,47 @@ 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) -toSet :: (Ord a) => LNGroup a -> Set a-toSet = S.fromList . map snd+getRoots :: GraphData a b -> IntSet+getRoots = I.fromList . applyAlg rootsOf' -getRoots :: (Ord a) => GraphData a b -> Set a-getRoots = toSet . applyAlg rootsOf+getLeaves :: GraphData a b -> IntSet+getLeaves = I.fromList . applyAlg leavesOf' -getLeaves :: (Ord a) => GraphData a b -> Set a-getLeaves = toSet . applyAlg leavesOf+getWRoots :: GraphData a b -> IntSet+getWRoots = I.fromList . wantedRootNodes -getWRoots :: (Ord a) => GraphData a b -> Set a-getWRoots = toSet . wantedRoots+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 @@ -128,14 +152,14 @@ nAttr callAttributes' where- gAttrs = [NodeAttrs [Margin . PVal $ PointD 0.5 0.2]] -- [GraphAttrs [Label $ StrLabel t]]+ 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 False mm+ nAttr = entityAttributes rs ls es (not $ isJust mm) mm -- | One-module-per-cluster 'DotGraph' drawGraph' :: String -> HSData -> DotGraph Node@@ -146,7 +170,7 @@ nAttr callAttributes' where- gAttrs = [NodeAttrs [Margin . PVal $ PointD 0.5 0.2]] -- [GraphAttrs [Label $ StrLabel t]]+ gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] dg' = updateGraph (compactSame . collapseStructures') dg rs = getRoots dg ls = getLeaves dg@@ -155,32 +179,20 @@ -- | GetRoots, GetLeaves, Exported, @'Just' m@ if only one module, @'Nothing'@ if all. -- 'True' if add explicit module name to all entities.-entityAttributes :: Set Entity -> Set Entity -> Set Entity -> Bool+entityAttributes :: IntSet -> IntSet -> IntSet -> Bool -> Maybe ModName -> LNode Entity -> Attributes-entityAttributes rs ls ex a mm (_,e@(Ent m n t))+entityAttributes rs ls ex a mm (n,(Ent m nm t)) = [ Label $ StrLabel lbl , Shape $ shapeFor t -- , Color [ColorName cl]- , FillColor $ ColorName sh+ , 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" ++ n) n+ lbl = bool (nameOfModule m ++ "\\n" ++ nm) nm $ not sameMod || a- -- Using the default X11 color names.- {-- isR = e `S.member` rs- isL = e `S.member` ls- -}- isE = e `S.member` ex- {-- cl | isR && not isE = "red"- | isR = "mediumblue"- | isL = "forestgreen"- | otherwise = "black"- -}- sh | isE = "gold"- | otherwise = "beige" sameMod = maybe True ((==) m) mm shapeFor :: EntityType -> Shape@@ -242,7 +254,7 @@ modClustAttrs :: ModName -> [GlobalAttributes] modClustAttrs m = [GraphAttrs [ Label . StrLabel $ nameOfModule m , Style [SItem Filled []]- , FillColor $ ColorName "wheat1"+ , FillColor $ ColorName "lavender" ] ] @@ -257,9 +269,9 @@ nAttr callAttributes' where- gAttrs = [NodeAttrs [Margin . PVal $ PointD 0.5 0.2]] -- [GraphAttrs [Label $ StrLabel t]]+ gAttrs = [nodeAttrs] -- [GraphAttrs [Label $ StrLabel t]] cAttr = [GraphAttrs [ Style [SItem Filled []]- , FillColor $ ColorName "wheat1"+ , FillColor $ ColorName "lavender" ] ] dg' = updateGraph (compactSame . cf . collapseStructures') dg@@ -281,24 +293,12 @@ (const []) where cID s = bool (Just $ Str s) Nothing $ (not . null) s- gAttrs = [NodeAttrs [Margin . PVal $ PointD 0.5 0.2]] --[GraphAttrs [Label $ StrLabel t]]+ gAttrs = [nodeAttrs] --[GraphAttrs [Label $ StrLabel t]] cAttr p = [GraphAttrs [Label $ StrLabel p]]- rs = I.fromList $ applyAlg rootsOf' dg- ls = I.fromList $ applyAlg leavesOf' dg- es = I.fromList $ wantedRootNodes dg+ rs = getRoots dg+ ls = getLeaves dg+ es = getWRoots dg nAttr (n,m) = [ Label $ StrLabel m- , FillColor $ ColorName $ mCol rs ls es n- , Style [SItem Filled []]+ , FillColor $ entCol rs ls es n , Shape Tab ]--mCol :: IntSet -> IntSet -> IntSet -> Node -> String-mCol rs ls es n- | isR && not isE = "crimson"- | isR = "gold"- | isL = "cyan"- | otherwise = "bisque"- where- isR = n `I.member` rs- isL = n `I.member` ls- isE = n `I.member` es
ChangeLog view
@@ -1,6 +1,17 @@-Changes since 0.5.2.0-=====================+Changes in 0.5.5.0+================== +* Class instances now drawn correctly.++* Better colour support.++* Now has a legend.++* Clean up printing of cliques, etc.++Changes in 0.5.2.0+==================+ * Shift overall analysis to the top and per-module analysis to the end, as suggested by Duncan Coutts. @@ -10,8 +21,8 @@ * Improve some graph drawing aspects (node margins, colours for module graphs, etc.). -Changes since 0.5.1.0-=====================+Changes in 0.5.1.0+================== * Add support for passing a single Haskell source file rather than a Cabal file as the argument, as requested by Curt Sampson.@@ -21,8 +32,8 @@ * RelativeNeighbourhood doesn't provide good alternate modules and takes up too much runtime, and so has been removed. -Changes since 0.5.0.0-=====================+Changes in 0.5.0.0+================== * Re-write of parsing.
KnownProblems.txt view
@@ -1,14 +1,6 @@ This is a list of known problems with SourceGraph except for those related to parsing. -* Node-based reporting (cycles, etc.) get confused with Class- functions.- * Printing of labels doesn't always turn out so well (overlaps, etc.).--* For some reason, a lot of class instance functions won't get drawn- in their clusters like they're meant to. Not sure why, as the- generated Dot code looks right (this might be from a limitation of- dot...). * No options on what to do, etc.
Main.hs view
@@ -256,7 +256,8 @@ , title = t , author = a , date = d- , content = msg : c g+ , legend = sgLegend+ , content = msg : linkMsg : c g } rt = fp </> programmeName sv s v = s ++ " (version " ++ v ++ ")"@@ -272,5 +273,7 @@ , Text " is " , Bold $ Text "not" , Text " a refactoring tool, and it's usage of Classes is\- \ not yet perfect."+ \ still premature." ]+ linkMsg = Paragraph [Text "All graph visualisations link to larger \+ \SVG versions of the same graph."]
Parsing/ParseModule.hs view
@@ -333,7 +333,7 @@ iDcls = S.map snd cis `S.union` instDecls pm cis' = MS.fromList $ S.toList cis -- DefInst calls- mkiCl(t,f) = FC f t DefaultInstDeclaration+ mkiCl (f,t) = FC f t DefaultInstDeclaration ciCls = MS.map mkiCl cis' -- Calls for that instance is = MS.map snd cis'@@ -393,7 +393,7 @@ iDcls = S.map snd cis `S.union` instDecls pm cis' = MS.fromList $ S.toList cis -- DefInst calls- mkiCl(t,f) = FC f t InstanceDeclaration+ mkiCl (f,t) = FC f t InstanceDeclaration ciCls = MS.map mkiCl cis' -- Calls for that instance is = MS.map snd cis'
Parsing/Types.hs view
@@ -397,6 +397,10 @@ | RecordConstructor deriving (Eq, Ord, Show, Read) +isNormalCall :: CallType -> Bool+isNormalCall NormalCall = True+isNormalCall _ = False+ data EntityType = Constructor DataType | RecordFunction DataType -- (Maybe EntityName) -- same record function in
SourceGraph.cabal view
@@ -1,9 +1,10 @@ Name: SourceGraph-Version: 0.5.2.0-Synopsis: Use graph-theory to analyse your code+Version: 0.5.5.0+Synopsis: Static code analysis using graph-theoretic techniques. Description: { Statically analyse Haskell source code using graph-theoretic-techniques.+techniques. Sample reports can be found at:+<http://code.haskell.org/~ivanm/Sample_SourceGraph/SampleReports.html> . To use SourceGraph, call it as either: .@@ -20,7 +21,7 @@ name of project and assumes that it is the only exported module; as such, it works better for programs than libraries). .-Whichever way your run SourceGraph, it then creates a @SourceGraph@+Whichever way you run SourceGraph, it then creates a @SourceGraph@ subdirectory in the same directory as the file that was passed to it, and within that subdirectory creates the analysis report in @Foo.html@.@@ -72,7 +73,7 @@ random, directory, fgl,- Graphalyze >= 0.7.0.0 && < 0.8.0.0,+ 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
TODO view
@@ -11,9 +11,3 @@ -- Mainly done, could possibly be smarter * Write a README--* Find where spurious class function entities are coming from.--* Fix up printing of entities for node lists.--* Add a legend.