SourceGraph 0.7.0.0 → 0.7.0.1
raw patch · 6 files changed
+157/−154 lines, 6 filesdep ~Graphalyzedep ~graphvizdep ~haskell-src-exts
Dependency ranges changed: Graphalyze, graphviz, haskell-src-exts
Files
- Analyse.hs +56/−53
- Analyse/Colors.hs +25/−25
- Analyse/GraphRepr.hs +10/−10
- Analyse/Visualise.hs +55/−55
- Parsing/Types.hs +7/−7
- SourceGraph.cabal +4/−4
Analyse.hs view
@@ -37,8 +37,11 @@ import Data.Graph.Analysis hiding (Bold) import qualified Data.Graph.Analysis.Reporting as R (DocInline(Bold))-import Data.GraphViz.Types+import Data.GraphViz.Types.Canonical import Data.GraphViz.Attributes+import Data.GraphViz.Attributes.Complete( Attribute(OutputOrder, FontSize, Rank)+ , OutputMode(EdgesFirst)+ , RankType(MinRank)) import System.Random(RandomGen) import Control.Arrow(first)@@ -70,13 +73,13 @@ where dg' = DG "legend_call" (Text "Function Call") dg dg = mkLegendGraph ns es- nAs = [Shape BoxShape, FillColor defaultNodeColor]- ns = [ (1, Label (StrLabel e1) : nAs)- , (2, Label (StrLabel e2) : nAs)+ nAs = [shape BoxShape, fillColor defaultNodeColor]+ ns = [ (1, toLabel e1 : nAs)+ , (2, toLabel e2 : nAs) ] e1 = "f" e2 = "g"- eAs = [Color [X11Color Black]]+ eAs = [color Black] es = [(1,2,eAs)] txt = Grouping [ Text "Two normal functions with" , Emphasis $ Text e1@@ -89,9 +92,9 @@ where dg' = DG "legend_mods" (Text "Module Import") dg dg = mkLegendGraph ns es- nAs = [Shape Tab, FillColor defaultNodeColor]- ns = [ (1, Label (StrLabel m1) : nAs)- , (2, Label (StrLabel m2) : nAs)+ nAs = [shape Tab, fillColor defaultNodeColor]+ ns = [ (1, toLabel m1 : nAs)+ , (2, toLabel m2 : nAs) ] m1 = "Foo" m2 = "Bar"@@ -107,15 +110,15 @@ where dg' = DG "legend_loc" (Text "From module") dg dg = mkLegendGraph ns es- nAs = [FillColor defaultNodeColor]- 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)+ nAs = [fillColor defaultNodeColor]+ ns = [ (1, toLabel "Current module"+ : style bold : nAs)+ , (2, toLabel "Other project module"+ : style solid : nAs)+ , (3, toLabel "Known external module"+ : style dashed : nAs)+ , (4, toLabel "Unknown external module"+ : style dotted : nAs) ] es = [] @@ -123,29 +126,29 @@ where dg' = DG "legend_data" (Text "Data type declaration") dg dg = mkLegendGraph ns es- nAs = [FillColor defaultNodeColor]- ns = [ (1, Label (StrLabel "Constructor")- : Shape Box3D : nAs)- , (2, Label (StrLabel "Record function")- : Shape Component : nAs)+ nAs = [fillColor defaultNodeColor]+ ns = [ (1, toLabel "Constructor"+ : shape Box3D : nAs)+ , (2, toLabel "Record function"+ : shape Component : nAs) ]- es = [(2,1,[ Color [X11Color Magenta], ArrowTail oDot, ArrowHead vee])]+ es = [(2,1,[ color Magenta, arrowFrom oDot, arrowTo vee])] esClass = (dg', R.Bold $ Text "Class and instance declarations.") where dg' = DG "legend_class" (Text "Class declaration") dg dg = mkLegendGraph ns es- nAs = [FillColor defaultNodeColor]- 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)+ nAs = [fillColor defaultNodeColor]+ ns = [ (1, toLabel "Default instance"+ : shape Octagon : nAs)+ , (2, toLabel "Class function"+ : shape DoubleOctagon : nAs)+ , (3, toLabel "Instance for data type"+ : shape Octagon : nAs) ]- eAs = [Dir NoDir]- es = [ (2,1, Color [X11Color Navy] : eAs)- , (2,3, Color [X11Color Turquoise] : eAs)+ eAs = [edgeEnds NoDir]+ es = [ (2,1, color Navy : eAs)+ , (2,3, color Turquoise : eAs) ] esExp = (dg', R.Bold $ Text "Entity location/accessibility classification.")@@ -153,18 +156,18 @@ dg' = DG "legend_loc2" (Text "Entity Location") dg dg = mkLegendGraph ns es 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]+ [ [ toLabel "Inaccessible entity"+ , fillColor inaccessibleColor]+ , [ toLabel "Exported root entity"+ , fillColor exportedRootColor]+ , [ toLabel "Exported non-root entity"+ , fillColor exportedInnerColor]+ , [ toLabel "Implicitly exported entity"+ , fillColor implicitExportColor]+ , [ toLabel "Leaf entity"+ , fillColor leafColor]+ , [ toLabel "Normal entity"+ , fillColor defaultNodeColor] ] es = [] @@ -172,12 +175,12 @@ 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]])+ ns = map (flip (,) [toLabel "", shape PointShape]) [1..5]+ eA = edgeEnds NoDir+ es = [ (1,2, [eA, toLabel "Clique", color cliqueColor])+ , (2,3, [eA, toLabel "Cycle", color cycleColor])+ , (3,4, [eA, toLabel "Chain", color chainColor])+ , (4,5, [eA, toLabel "Normal", color defaultEdgeColor]) ] @@ -195,7 +198,7 @@ } where atts = [ GraphAttrs [OutputOrder EdgesFirst]- , NodeAttrs [FontSize 10, Style [SItem Filled []]]+ , NodeAttrs [FontSize 10, style filled] ] sgAtts = [GraphAttrs [Rank MinRank]] nSG = DotSG { isCluster = False@@ -207,7 +210,7 @@ } } mkN (n,as) = DotNode n as- mkE (f,t,as) = DotEdge f t True as+ mkE (f,t,as) = DotEdge f t as edgeExplain :: (DocInline, DocInline) edgeExplain = (Grouping cntnt, R.Bold $ Text "Edge Widths")
Analyse/Colors.hs view
@@ -29,40 +29,40 @@ -} module Analyse.Colors where -import Data.GraphViz.Attributes.Colors+import Data.GraphViz.Attributes -inaccessibleColor :: Color-inaccessibleColor = X11Color Crimson+inaccessibleColor :: X11Color+inaccessibleColor = Crimson -exportedRootColor :: Color-exportedRootColor = X11Color Gold+exportedRootColor :: X11Color+exportedRootColor = Gold -exportedInnerColor :: Color-exportedInnerColor = X11Color Goldenrod+exportedInnerColor :: X11Color+exportedInnerColor = Goldenrod -implicitExportColor :: Color-implicitExportColor = X11Color Khaki+implicitExportColor :: X11Color+implicitExportColor = Khaki -leafColor :: Color-leafColor = X11Color Cyan+leafColor :: X11Color+leafColor = Cyan -defaultNodeColor :: Color-defaultNodeColor = X11Color Bisque+defaultNodeColor :: X11Color+defaultNodeColor = Bisque -defaultEdgeColor :: Color-defaultEdgeColor = X11Color Black+defaultEdgeColor :: X11Color+defaultEdgeColor = Black -cliqueColor :: Color-cliqueColor = X11Color Orange+cliqueColor :: X11Color+cliqueColor = Orange -cycleColor :: Color-cycleColor = X11Color DarkOrchid+cycleColor :: X11Color+cycleColor = DarkOrchid -chainColor :: Color-chainColor = X11Color Chartreuse+chainColor :: X11Color+chainColor = Chartreuse -clusterBackground :: Color-clusterBackground = X11Color Lavender+clusterBackground :: X11Color+clusterBackground = Lavender -noBackground :: Color-noBackground = X11Color Snow+noBackground :: X11Color+noBackground = Snow
Analyse/GraphRepr.hs view
@@ -70,7 +70,7 @@ import Data.Graph.Analysis import Data.Graph.Inductive-import Data.GraphViz.Attributes.Colors(Color)+import Data.GraphViz.Attributes(X11Color) import Data.List(isPrefixOf) import Data.Maybe(mapMaybe)@@ -84,12 +84,12 @@ data GData n e = GD { graphData :: GraphData n e , compactData :: GraphData n (Int, e)- , nodeCols :: [(Set Node, Color)]- , edgeCols :: [(Set Edge, Color)]+ , nodeCols :: [(Set Node, X11Color)]+ , edgeCols :: [(Set Edge, X11Color)] } -mkGData :: (Ord e) => (GraphData n e -> [(Set Node, Color)])- -> (GraphData n e -> [(Set Edge, Color)])+mkGData :: (Ord e) => (GraphData n e -> [(Set Node, X11Color)])+ -> (GraphData n e -> [(Set Edge, X11Color)]) -> GraphData n e -> GData n e mkGData n e g = GD { graphData = g , compactData = updateGraph compactSame g@@ -112,7 +112,7 @@ 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 :: GraphData n e -> [(Set Node, X11Color)] commonColors gd = [ (rs', exportedRootColor) , (es, exportedInnerColor) , (ls, leafColor)@@ -178,7 +178,7 @@ type HSGraph = AGr Entity CallType type HSClustGraph = AGr (GenCluster Entity) CallType -entColors :: Set Entity -> GraphData Entity e -> [(Set Node, Color)]+entColors :: Set Entity -> GraphData Entity e -> [(Set Node, X11Color)] entColors vs hd = (us, inaccessibleColor) : commonColors hd@@ -192,7 +192,7 @@ us = inaccessibleNodes hd' imps = implicitExports vs hd -callColors :: HSData -> [(Set Edge, Color)]+callColors :: HSData -> [(Set Edge, X11Color)] callColors hd = [ (cliqueEdges clqs, cliqueColor) , (cycleEdges cycs, cycleColor) , (chainEdges chns, chainColor)@@ -283,12 +283,12 @@ type ModData = GraphData ModName () type ModGraph = AGr ModName () -modColors :: GraphData ModName e -> [(Set Node, Color)]+modColors :: GraphData ModName e -> [(Set Node, X11Color)] modColors gd = (us, inaccessibleColor) : commonColors gd where us = inaccessibleNodes gd -modEdgeColors :: (Eq e) => GraphData ModName e -> [(Set Edge, Color)]+modEdgeColors :: (Eq e) => GraphData ModName e -> [(Set Edge, X11Color)] modEdgeColors gd = [ (cycleEdges cycs, cycleColor) , (chainEdges chns, chainColor) ]
Analyse/Visualise.hs view
@@ -36,6 +36,7 @@ import Data.Graph.Analysis hiding (Bold) import Data.GraphViz+import Data.GraphViz.Attributes.Complete(Attribute(Margin), DPoint(PVal), createPoint) import Data.Maybe(isNothing) import Data.List(find)@@ -45,7 +46,7 @@ -- | Create the nested 'DotGraph'. drawGraph :: String -> Maybe ModName -> HData' -> DotGraph Node-drawGraph gid mm dg = setID (Str gid)+drawGraph gid mm dg = setID (clustID gid) . graphviz params $ compactData dg' where@@ -59,10 +60,10 @@ -- | One-module-per-cluster 'DotGraph'. drawGraph' :: String -> HData' -> DotGraph Node-drawGraph' gid dg = setID (Str gid)+drawGraph' gid dg = setID (clustID gid) . graphvizClusters params $ compactData dg' where- params = Params True gAttrs N (const Nothing) modClustAttrs nAttr eAttr+ params = Params True gAttrs N undefined modClustAttrs nAttr eAttr dg' = collapsedHData dg gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] nAttr = entityAttributes dg' False Nothing@@ -76,12 +77,12 @@ -> LNode Entity -> Attributes entityAttributes hd a mm (n,Ent m nm t) = [ toLabel lbl- , Shape $ shapeFor t- -- , Color [ColorName cl]- , FillColor $ entCol hd n+ , 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]+ , styles [filled, styleFor mm m] ] where lbl = bool nm (nameOfModule m ++ "\\n" ++ nm)@@ -99,57 +100,56 @@ 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 []+styleFor :: Maybe ModName -> ModName -> Style+styleFor mm m@LocalMod{} = bool solid bold $ maybe False (m==) mm+styleFor _ ExtMod{} = dashed+styleFor _ UnknownMod = dotted callAttributes :: GData n e -> Edge -> CallType -> Attributes-callAttributes hd e NormalCall = [ Color [edgeCol hd e]]-callAttributes _ _ InstanceDeclaration = [ Color [X11Color Navy]- , Dir NoDir+callAttributes hd e NormalCall = [ color $ edgeCol hd e]+callAttributes _ _ InstanceDeclaration = [ color Navy+ , edgeEnds NoDir ]-callAttributes _ _ DefaultInstDeclaration = [ Color [X11Color Turquoise]- , Dir NoDir+callAttributes _ _ DefaultInstDeclaration = [ color Turquoise+ , edgeEnds NoDir ]-callAttributes _ _ RecordConstructor = [ Color [X11Color Magenta]- , ArrowTail oDot- , ArrowHead vee+callAttributes _ _ RecordConstructor = [ color Magenta+ , arrowFrom oDot+ , arrowTo vee ] callAttributes' :: GData n e -> LEdge (Int, CallType) -> Attributes-callAttributes' hd (f,t,(n,ct)) = PenWidth (log (fromIntegral n) + 1)+callAttributes' hd (f,t,(n,ct)) = penWidth (log (fromIntegral n) + 1) : callAttributes hd (f,t) ct clustAttributes :: EntClustType -> Attributes-clustAttributes (ClassDefn c) = [ Label . StrLabel $ "Class: " ++ c- , Style [SItem Filled [], SItem Rounded []]- , FillColor $ X11Color RosyBrown1+clustAttributes (ClassDefn c) = [ toLabel $ "Class: " ++ c+ , styles [filled, rounded]+ , fillColor RosyBrown1 ]-clustAttributes (DataDefn d) = [ Label . StrLabel $ "Data: " ++ d- , Style [SItem Filled [], SItem Rounded []]- , FillColor $ X11Color PapayaWhip+clustAttributes (DataDefn d) = [ toLabel $ "Data: " ++ d+ , styles [filled, rounded]+ , fillColor 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 (ClassInst _ d) = [ toLabel $ "Instance for: " ++ d+ , styles [filled, rounded]+ , fillColor SlateGray1 ]+clustAttributes DefInst{} = [ toLabel $ "Default Instance"+ , styles [filled, rounded]+ , fillColor SlateGray1+ ] clustAttributes (ModPath p) = [ toLabel p ] clustAttributes' :: EntClustType -> [GlobalAttributes] clustAttributes' = return . GraphAttrs . clustAttributes modClustAttrs :: ModName -> [GlobalAttributes]-modClustAttrs m = [GraphAttrs [ Label . StrLabel $ nameOfModule m- , Style [SItem Filled []]- , FillColor clusterBackground+modClustAttrs m = [GraphAttrs [ toLabel $ nameOfModule m+ , style filled+ , fillColor clusterBackground ] ] @@ -159,7 +159,7 @@ -- function shouldn't touch the the actual 'Node' values. drawClusters :: String -> (HSGraph -> HSClustGraph) -> HData' -> DotGraph Node-drawClusters gid cf dg = setID (Str gid)+drawClusters gid cf dg = setID (clustID gid) . graphvizClusters params $ compactData dg' where params = blankParams { globalAttributes = gAttrs@@ -169,15 +169,15 @@ } dg' = mapData' cf $ collapsedHData dg gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]]- cAttr = [GraphAttrs [ Style [SItem Filled []]- , FillColor clusterBackground+ cAttr = [GraphAttrs [ style filled+ , fillColor clusterBackground ] ] nAttr = entityAttributes dg' True Nothing eAttr = callAttributes' dg' drawLevels :: String -> Maybe ModName -> HData' -> DotGraph Node-drawLevels gid mm hd = setID (Str gid)+drawLevels gid mm hd = setID (clustID gid) $ graphvizClusters params dg' where params = blankParams { globalAttributes = gAttrs@@ -200,9 +200,9 @@ | l == minLevel = atts "Exported root entities" | otherwise = atts $ "Level = " ++ show l where- atts t = [GraphAttrs [ Label (StrLabel t)- , Style [SItem Filled []]- , FillColor clusterBackground+ atts t = [GraphAttrs [ toLabel t+ , style filled+ , fillColor clusterBackground ] ] @@ -210,30 +210,30 @@ -- Dealing with inter-module imports, etc. drawModules :: String -> MData -> DotGraph Node-drawModules gid md = setID (Str gid)+drawModules gid md = setID (clustID gid) . graphviz params $ graphData md where params = Params True gAttrs clusteredModule cID cAttr nAttr eAttr- cID (_,s) = bool Nothing (Just $ Str s) $ (not . null) s+ cID (_,s) = bool undefined (clustID s) $ (not . null) s gAttrs = [nodeAttrs] -- [GraphAttrs [toLabel t]] cAttr dp = [GraphAttrs $ directoryAttributes dp] nAttr (n,m) = [ toLabel m- , FillColor $ entCol md n- , Shape Tab+ , fillColor $ entCol md n+ , shape Tab ]- eAttr le = [Color [edgeCol md $ edge le]]+ eAttr le = [color . edgeCol md $ edge le] directoryAttributes :: (Depth, String) -> Attributes-directoryAttributes (d,n) = col : [Style [SItem Filled []]- , Label (StrLabel n)+directoryAttributes (d,n) = col : [ style filled+ , toLabel n ] where- col = bool (FillColor noBackground) (FillColor clusterBackground)+ col = bool (fillColor noBackground) (fillColor clusterBackground) $ d `mod` 2 == 0 -- ----------------------------------------------------------------------------- -entCol :: GData n e -> Node -> Color+entCol :: GData n e -> Node -> X11Color entCol d n = maybe defaultNodeColor snd . find hasNode $ nodeCols d@@ -242,10 +242,10 @@ nodeAttrs :: GlobalAttributes nodeAttrs = NodeAttrs [ Margin . PVal $ createPoint 0.4 0.1- , Style [SItem Filled []]+ , style filled ] -edgeCol :: GData n e -> Edge -> Color+edgeCol :: GData n e -> Edge -> X11Color edgeCol d e = maybe defaultEdgeColor snd . find hasEdge $ edgeCols d
Parsing/Types.hs view
@@ -204,7 +204,7 @@ go _ [] = error "Shouldn't be able to have an empty module name." instance ClusterType ModName where- clustID = Just . Str . unDotPath . nameOfModule+ clustID = clustID . unDotPath . nameOfModule instance ClusterLabel ModName where type Cluster ModName = String@@ -324,12 +324,12 @@ | ModPath String deriving (Eq, Ord, Show, Read) -ctypeID :: EntClustType -> Maybe GraphID-ctypeID (ClassDefn c) = Just . Str $ "Class_" ++ escID c-ctypeID (DataDefn d) = Just . Str $ "Data_" ++ escID d-ctypeID (ClassInst c d) = Just . Str $ "Class_" ++ escID c ++ "_Data_" ++ escID d-ctypeID (DefInst c) = Just . Str $ "DefaultInstance_" ++ escID c-ctypeID (ModPath p) = Just . Str $ "Directory_" ++ escID p+ctypeID :: EntClustType -> GraphID+ctypeID (ClassDefn c) = clustID $ "Class_" ++ escID c+ctypeID (DataDefn d) = clustID $ "Data_" ++ escID d+ctypeID (ClassInst c d) = clustID $ "Class_" ++ escID c ++ "_Data_" ++ escID d+ctypeID (DefInst c) = clustID $ "DefaultInstance_" ++ escID c+ctypeID (ModPath p) = clustID $ "Directory_" ++ escID p escID :: String -> String escID = filter (\c -> isLetter c || isDigit c || c == '_')
SourceGraph.cabal view
@@ -1,5 +1,5 @@ Name: SourceGraph-Version: 0.7.0.0+Version: 0.7.0.1 Synopsis: Static code analysis using graph-theoretic techniques. Description: { Statically analyse Haskell source code using graph-theoretic@@ -76,8 +76,8 @@ directory, mtl, fgl >= 5.4.2.3 && < 5.5,- Graphalyze >= 0.11.0.0 && < 0.12.0.0,- graphviz >= 2999.11.0.0 && < 2999.12.0.0,+ Graphalyze == 0.12.*,+ graphviz == 2999.12.*, Cabal >= 1.8 && < 1.11,- haskell-src-exts >= 1.5.0 && < 1.10.0+ haskell-src-exts >= 1.5.0 && < 1.12.0 }