github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-23 06:41:45 +03:00
Code Issues Projects Releases Wiki Activity

Define Analysis.Abstract.Graph using Data.Graph.

Browse Source
This commit is contained in:
Rob Rix 2018-05-11 12:22:51 -04:00
parent 65259053f4
commit 5722538805
1 changed files with 15 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
src/Analysis/Abstract/Graph.hs
View File

@ -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