github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 00:33:59 +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 , renderDOTTerm
) where ) where
import Algebra.Graph
import Algebra.Graph.Export.Dot
import Analysis.ConstructorName import Analysis.ConstructorName
import Control.Applicative
import Data.Blob import Data.Blob
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Diff import Data.Diff
import Data.Foldable import Data.Foldable
import Data.Functor.Foldable hiding (fold) import Data.Functor.Foldable hiding (fold)
import qualified Data.Map as Map import qualified Data.IntMap as IntMap
import Data.Patch import Data.Patch
import Data.Semigroup import Data.Semigroup
import Data.Term import Data.Term
renderDOTDiff :: (ConstructorName syntax, Foldable syntax, Functor syntax) => BlobPair -> Diff syntax ann1 ann2 -> B.ByteString 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)) } renderDOTDiff blobs diff = renderGraph (defaultStyleViaShow { graphName = B.pack (quote (pathKeyForBlobPair blobs)) }) (cata diffAlgebra diff 0 [])
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 <> "}"
where quote a = "\"" <> a <> "\"" where quote a = "\"" <> a <> "\""
renderNode :: Node -> B.ByteString renderDOTTerm :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Blob -> Term syntax ann -> B.ByteString
renderNode Node{..} = "\t" <> B.pack (show nodeID) <> " [ " <> foldr (\ (key, value) rest -> key <> " = \"" <> value <> "\" " <> rest) "" (Map.toList nodeAttributes) <> "];\n" renderDOTTerm Blob{..} term = renderGraph (defaultStyleViaShow { graphName = B.pack blobPath }) (cata termAlgebra term 0 [])
renderEdge :: Edge -> B.ByteString diffAlgebra :: (ConstructorName syntax, Foldable syntax) => DiffF syntax ann1 ann2 (Int -> [Attribute B.ByteString] -> State) -> Int -> [Attribute B.ByteString] -> State
renderEdge Edge{..} = "\t" <> B.pack (show edgeFrom) <> " -> " <> B.pack (show edgeTo) <> ";\n" 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 data State = State { stateRoots :: [Int], stateGraph :: Graph Int, stateVertexAttributes :: IntMap.IntMap [Attribute B.ByteString] }
Graph n1 ns1 es1 <> Graph n2 ns2 es2 = Graph (n1 <|> n2) (ns1 <> ns2) (es1 <> es2)
instance Monoid Graph where instance Semigroup State where
mempty = Graph Nothing [] [] State r1 g1 v1 <> State r2 g2 v2 = State (r1 <> r2) (g1 `overlay` g2) (v1 <> v2)
mappend = (<>)
renderGraph :: Style Int B.ByteString -> State -> B.ByteString
renderGraph style State{..} = export (style { vertexAttributes = flip (IntMap.findWithDefault []) stateVertexAttributes }) stateGraph