github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

Generate DOT using algebraic-graphs.

Browse Source
This commit is contained in:
Rob Rix 2018-02-07 12:54:18 -05:00
parent 4ceddcd531
commit ac4ae43498
1 changed files with 25 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
src/Rendering/DOT.hs
View File

@ -4,68 +4,45 @@ module Rendering.DOT
, renderDOTTerm
) where
import Algebra.Graph
import Algebra.Graph.Export.Dot
import Analysis.ConstructorName
import Control.Applicative
import Data.Blob
import qualified Data.ByteString.Char8 as B
import Data.Diff
import Data.Foldable
import Data.Functor.Foldable hiding (fold)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Patch
import Data.Semigroup
import Data.Term
renderDOTDiff :: (ConstructorName syntax, Foldable syntax, Functor syntax) => BlobPair -> Diff syntax ann1 ann2 -> B.ByteString
renderDOTDiff blobs diff = renderGraph (snd (cata diffAlgebra diff 0)) { graphName = Just (B.pack (pathKeyForBlobPair blobs)) }
renderDOTTerm :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Blob -> Term syntax ann -> B.ByteString
renderDOTTerm Blob{..} term = renderGraph (snd (cata termAlgebra term 0)) { graphName = Just (B.pack blobPath) }
diffAlgebra :: (ConstructorName syntax, Foldable syntax) => DiffF syntax ann1 ann2 (Int -> ([Int], Graph)) -> Int -> ([Int], Graph)
diffAlgebra d i = case d of
Merge t -> termAlgebra t i
Patch (Delete t1) -> termAlgebra t1 i `modifyHeadNode` setColour "red"
Patch (Insert t2) -> termAlgebra t2 i `modifyHeadNode` setColour "green"
Patch (Replace t1 t2) -> let r1 = termAlgebra t1 i `modifyHeadNode` setColour "red"
in r1 <> termAlgebra t2 (succ (maximum (i : map nodeID (graphNodes (snd r1))))) `modifyHeadNode` setColour "green"
where modifyHeadNode (i, g) f | n:ns <- graphNodes g = (i, g { graphNodes = f n : ns })
| otherwise = (i, g)
setColour c n = n { nodeAttributes = Map.insert "color" c (nodeAttributes n) }
termAlgebra :: (ConstructorName syntax, Foldable syntax) => TermF syntax ann (Int -> ([Int], Graph)) -> Int -> ([Int], Graph)
termAlgebra t i = ([succ i], Graph
Nothing
(Node (succ i) (Map.singleton "label" (unConstructorLabel (constructorLabel t))) : graphNodes g)
(concatMap (map (Edge (succ i))) is <> graphEdges g))
where (_, is, g) = foldr combine (succ i, [], mempty) (toList t)
combine f (i, is, gs) = let (i', g) = f i in (maximum (i : map nodeID (graphNodes g)), i' : is, g <> gs)
data Graph = Graph { graphName :: Maybe B.ByteString, graphNodes :: [Node], graphEdges :: [Edge] }
deriving (Eq, Ord, Show)
data Node = Node { nodeID :: Int, nodeAttributes :: Map.Map B.ByteString B.ByteString }
deriving (Eq, Ord, Show)
data Edge = Edge { edgeFrom :: Int, edgeTo :: Int }
deriving (Eq, Ord, Show)
renderGraph :: Graph -> B.ByteString
renderGraph Graph{..} = "digraph " <> maybe "" quote graphName <> " {\n" <> foldr ((<>) . renderNode) "" graphNodes <> foldr ((<>) . renderEdge) "" graphEdges <> "}"
renderDOTDiff blobs diff = renderGraph (defaultStyleViaShow { graphName = B.pack (quote (pathKeyForBlobPair blobs)) }) (cata diffAlgebra diff 0 [])
where quote a = "\"" <> a <> "\""
renderNode :: Node -> B.ByteString
renderNode Node{..} = "\t" <> B.pack (show nodeID) <> " [ " <> foldr (\ (key, value) rest -> key <> " = \"" <> value <> "\" " <> rest) "" (Map.toList nodeAttributes) <> "];\n"
renderDOTTerm :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Blob -> Term syntax ann -> B.ByteString
renderDOTTerm Blob{..} term = renderGraph (defaultStyleViaShow { graphName = B.pack blobPath }) (cata termAlgebra term 0 [])
renderEdge :: Edge -> B.ByteString
renderEdge Edge{..} = "\t" <> B.pack (show edgeFrom) <> " -> " <> B.pack (show edgeTo) <> ";\n"
diffAlgebra :: (ConstructorName syntax, Foldable syntax) => DiffF syntax ann1 ann2 (Int -> [Attribute B.ByteString] -> State) -> Int -> [Attribute B.ByteString] -> State
diffAlgebra d i as = case d of
Merge t -> termAlgebra t i as
Patch (Delete t1) -> termAlgebra t1 i ("color" := "red" : as)
Patch (Insert t2) -> termAlgebra t2 i ("color" := "green" : as)
Patch (Replace t1 t2) -> let r1 = termAlgebra t1 i ("color" := "red" : as)
in r1 <> termAlgebra t2 (succ (maximum (i : toList (stateGraph r1)))) ("color" := "green" : as)
termAlgebra :: (ConstructorName syntax, Foldable syntax) => TermF syntax ann (Int -> [Attribute B.ByteString] -> State) -> Int -> [Attribute B.ByteString] -> State
termAlgebra t i as = State [succ i] g vattrs
where (_, g, vattrs) = foldr combine (succ i, vertex (succ i), IntMap.singleton (succ i) ("label" := unConstructorLabel (constructorLabel t) : as)) (toList t)
combine f (prev, g, attrs) = let State roots g' attrs' = f prev as in (maximum (prev : toList g'), foldr (overlay . connect (vertex (succ i)) . vertex) g' roots `overlay` g, attrs <> attrs')
instance Semigroup Graph where
Graph n1 ns1 es1 <> Graph n2 ns2 es2 = Graph (n1 <|> n2) (ns1 <> ns2) (es1 <> es2)
data State = State { stateRoots :: [Int], stateGraph :: Graph Int, stateVertexAttributes :: IntMap.IntMap [Attribute B.ByteString] }
instance Monoid Graph where
mempty = Graph Nothing [] []
mappend = (<>)
instance Semigroup State where
State r1 g1 v1 <> State r2 g2 v2 = State (r1 <> r2) (g1 `overlay` g2) (v1 <> v2)
renderGraph :: Style Int B.ByteString -> State -> B.ByteString
renderGraph style State{..} = export (style { vertexAttributes = flip (IntMap.findWithDefault []) stateVertexAttributes }) stateGraph