From 5722538805dc9a23f6cf4f0591b904f7a15b4fd8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 11 May 2018 12:22:51 -0400 Subject: [PATCH] Define Analysis.Abstract.Graph using Data.Graph. --- src/Analysis/Abstract/Graph.hs | 61 +++++++++------------------------- 1 file changed, 15 insertions(+), 46 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 433672d63..1483d8a15 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -14,9 +14,6 @@ module Analysis.Abstract.Graph , graphing ) where -import qualified Algebra.Graph as G -import qualified Algebra.Graph.Class as GC -import Algebra.Graph.Class hiding (Graph, Vertex) import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract import Data.Abstract.Address @@ -27,16 +24,13 @@ import Data.Abstract.Package (PackageInfo(..)) import Data.Aeson hiding (Result) import qualified Data.ByteString.Char8 as BC import Data.ByteString.Lazy (toStrict) +import Data.Graph import Data.Output import qualified Data.Syntax as Syntax import Data.Term import Data.Text.Encoding as T import Prologue hiding (empty, packageName) --- | The graph of function variableDefinitions to symbols used in a given program. -newtype Graph = Graph { unGraph :: G.Graph Vertex } - deriving (Eq, GC.Graph, Show) - -- | A vertex of some specific type. data Vertex = Package { vertexName :: ByteString } @@ -45,8 +39,8 @@ data Vertex deriving (Eq, Ord, Show) -- | Render a 'Graph' to a 'ByteString' in DOT notation. -renderGraph :: Graph -> ByteString -renderGraph = export style . unGraph +renderGraph :: Graph Vertex -> ByteString +renderGraph = export style style :: Style Vertex ByteString style = (defaultStyle vertexName) @@ -68,7 +62,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax , Reader ModuleInfo , Reader PackageInfo , State (Environment (Located location) value) - , State Graph + , State (Graph Vertex) ] effects , term ~ Term (Sum syntax) ann ) @@ -85,7 +79,7 @@ graphingTerms recur term@(In _ syntax) = do -- | Add vertices to the graph for 'LoadError's. graphingLoadErrors :: Members '[ Reader ModuleInfo , Resumable (LoadError location value) - , State Graph + , State (Graph Vertex) ] effects => SubtermAlgebra (Base term) term (Evaluator location value effects a) -> SubtermAlgebra (Base term) term (Evaluator location value effects a) @@ -94,7 +88,7 @@ graphingLoadErrors recur term = recur term `resumeLoadError` (\ (ModuleNotFound -- | Add vertices to the graph for evaluated modules and the packages containing them. graphingModules :: Members '[ Reader ModuleInfo , Reader PackageInfo - , State Graph + , State (Graph Vertex) ] effects => SubtermAlgebra Module term (Evaluator location value effects a) -> SubtermAlgebra Module term (Evaluator location value effects a) @@ -105,16 +99,16 @@ graphingModules recur m = do recur m -packageGraph :: PackageInfo -> Graph +packageGraph :: PackageInfo -> Graph Vertex packageGraph = vertex . Package . unName . packageName -moduleGraph :: ModuleInfo -> Graph +moduleGraph :: ModuleInfo -> Graph Vertex moduleGraph = vertex . Module . BC.pack . modulePath -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Effectful m , Members '[ Reader PackageInfo - , State Graph + , State (Graph Vertex) ] effects , Monad (m effects) ) @@ -127,7 +121,7 @@ packageInclusion v = do -- | Add an edge from the current module to the passed vertex. moduleInclusion :: ( Effectful m , Members '[ Reader ModuleInfo - , State Graph + , State (Graph Vertex) ] effects , Monad (m effects) ) @@ -140,46 +134,21 @@ moduleInclusion v = do -- | Add an edge from the passed variable name to the module it originated within. variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects , Member (State (Environment (Located location) value)) effects - , Member (State Graph) effects + , Member (State (Graph Vertex)) effects ) => Name -> Evaluator (Located location) value effects () variableDefinition name = do - graph <- maybe empty (moduleGraph . locationModule . unAddress) <$> lookupEnv name + graph <- maybe lowerBound (moduleGraph . locationModule . unAddress) <$> lookupEnv name appendGraph (vertex (Variable (unName name)) `connect` graph) -appendGraph :: (Effectful m, Member (State Graph) effects) => Graph -> m effects () +appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects () appendGraph = modify' . (<>) -instance Semigroup Graph where - (<>) = overlay - -instance Monoid Graph where - mempty = empty - mappend = (<>) - -instance Ord Graph where - compare (Graph G.Empty) (Graph G.Empty) = EQ - compare (Graph G.Empty) _ = LT - compare _ (Graph G.Empty) = GT - compare (Graph (G.Vertex a)) (Graph (G.Vertex b)) = compare a b - compare (Graph (G.Vertex _)) _ = LT - compare _ (Graph (G.Vertex _)) = GT - compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2 - compare (Graph (G.Overlay _ _)) _ = LT - compare _ (Graph (G.Overlay _ _)) = GT - compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2 - -instance Output Graph where +instance Output (Graph Vertex) where toOutput = toStrict . (<> "\n") . encode -instance ToJSON Graph where - toJSON Graph{..} = object [ "vertices" .= vertices, "edges" .= edges ] - where - vertices = toJSON (G.vertexList unGraph) - edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unGraph) - instance ToJSON Vertex where toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ] @@ -192,5 +161,5 @@ vertexToType Module{} = "module" vertexToType Variable{} = "variable" -graphing :: Effectful m => m (State Graph ': effects) result -> m effects (result, Graph) +graphing :: Effectful m => m (State (Graph Vertex) ': effects) result -> m effects (result, Graph Vertex) graphing = runState mempty