mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Merge master into 🔥-monolithic-syntax
This commit is contained in:
parent
a112fca6f3
commit
99d9b7c97a
@ -80,6 +80,7 @@ library
|
||||
, Parsing.TreeSitter
|
||||
, Paths_semantic_diff
|
||||
-- Rendering formats
|
||||
, Rendering.DOT
|
||||
, Rendering.JSON
|
||||
, Rendering.Renderer
|
||||
, Rendering.SExpression
|
||||
|
@ -19,7 +19,7 @@ constructorLabel :: ConstructorName syntax => TermF syntax a b -> ConstructorLab
|
||||
constructorLabel (In _ s) = ConstructorLabel $ pack (constructorName s)
|
||||
|
||||
|
||||
newtype ConstructorLabel = ConstructorLabel ByteString
|
||||
newtype ConstructorLabel = ConstructorLabel { unConstructorLabel :: ByteString }
|
||||
|
||||
instance Show ConstructorLabel where
|
||||
showsPrec _ (ConstructorLabel s) = showString (unpack s)
|
||||
|
74
src/Rendering/DOT.hs
Normal file
74
src/Rendering/DOT.hs
Normal file
@ -0,0 +1,74 @@
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
module Rendering.DOT
|
||||
( renderDOTDiff
|
||||
, renderDOTTerm
|
||||
) where
|
||||
|
||||
import Analysis.ConstructorName
|
||||
import Control.Applicative
|
||||
import Data.Bifunctor.Join (Join(..))
|
||||
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 Data.Patch
|
||||
import Data.Semigroup
|
||||
import Data.Term
|
||||
import Data.These (These, mergeThese)
|
||||
|
||||
renderDOTDiff :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Join These Blob -> Diff syntax ann1 ann2 -> B.ByteString
|
||||
renderDOTDiff blobs diff = renderGraph (snd (cata diffAlgebra diff 0)) { graphName = Just (B.pack (mergeThese combine (runJoin (blobPath <$> blobs)))) }
|
||||
where combine p1 p2 = p1 <> " -> " <> p2
|
||||
|
||||
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 <> "\""
|
||||
|
||||
renderNode :: Node -> B.ByteString
|
||||
renderNode Node{..} = "\t" <> B.pack (show nodeID) <> " [ " <> foldr (\ (key, value) rest -> key <> " = \"" <> value <> "\" " <> rest) "" (Map.toList nodeAttributes) <> "];\n"
|
||||
|
||||
renderEdge :: Edge -> B.ByteString
|
||||
renderEdge Edge{..} = "\t" <> B.pack (show edgeFrom) <> " -> " <> B.pack (show edgeTo) <> ";\n"
|
||||
|
||||
|
||||
instance Semigroup Graph where
|
||||
Graph n1 ns1 es1 <> Graph n2 ns2 es2 = Graph (n1 <|> n2) (ns1 <> ns2) (es1 <> es2)
|
||||
|
||||
instance Monoid Graph where
|
||||
mempty = Graph Nothing [] []
|
||||
mappend = (<>)
|
@ -10,6 +10,8 @@ module Rendering.Renderer
|
||||
, renderToCDiff
|
||||
, renderToCTerm
|
||||
, renderToTags
|
||||
, renderDOTDiff
|
||||
, renderDOTTerm
|
||||
, Summaries(..)
|
||||
) where
|
||||
|
||||
@ -18,6 +20,7 @@ import Data.ByteString (ByteString)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Output
|
||||
import Data.Text (Text)
|
||||
import Rendering.DOT as R
|
||||
import Rendering.JSON as R
|
||||
import Rendering.SExpression as R
|
||||
import Rendering.Tag as R
|
||||
@ -31,6 +34,8 @@ data DiffRenderer output where
|
||||
JSONDiffRenderer :: DiffRenderer (Map.Map Text Value)
|
||||
-- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
|
||||
SExpressionDiffRenderer :: DiffRenderer ByteString
|
||||
-- | Render to a 'ByteString' formatted as a DOT description of the diff.
|
||||
DOTDiffRenderer :: DiffRenderer ByteString
|
||||
|
||||
deriving instance Eq (DiffRenderer output)
|
||||
deriving instance Show (DiffRenderer output)
|
||||
@ -45,6 +50,8 @@ data TermRenderer output where
|
||||
SExpressionTermRenderer :: TermRenderer ByteString
|
||||
-- | Render to a list of tags.
|
||||
TagsTermRenderer :: TermRenderer [Value]
|
||||
-- | Render to a 'ByteString' formatted as a DOT description of the term.
|
||||
DOTTermRenderer :: TermRenderer ByteString
|
||||
|
||||
deriving instance Eq (TermRenderer output)
|
||||
deriving instance Show (TermRenderer output)
|
||||
|
@ -53,7 +53,7 @@ parseBlob renderer blob@Blob{..}
|
||||
JSONTermRenderer -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
|
||||
SExpressionTermRenderer -> decorate constructorLabel . (Nil <$) >=> render renderSExpressionTerm
|
||||
TagsTermRenderer -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)
|
||||
|
||||
DOTTermRenderer -> render (renderDOTTerm blob)
|
||||
| otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
|
||||
|
||||
data NoLanguageForBlob = NoLanguageForBlob FilePath
|
||||
@ -71,7 +71,7 @@ diffBlobPair renderer blobs
|
||||
ToCDiffRenderer -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) diffTerms renderToCDiff
|
||||
JSONDiffRenderer -> run ( parse parser >=> decorate constructorLabel >=> decorate identifierLabel) diffTerms renderJSONDiff
|
||||
SExpressionDiffRenderer -> run ( parse parser >=> decorate constructorLabel . (Nil <$)) diffTerms (const renderSExpressionDiff)
|
||||
|
||||
DOTDiffRenderer -> run ( parse parser) diffTerms renderDOTDiff
|
||||
| otherwise = throwError (SomeException (NoLanguageForBlob effectivePath))
|
||||
where effectivePath = pathForBlobPair blobs
|
||||
effectiveLanguage = languageForBlobPair blobs
|
||||
|
@ -65,7 +65,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
<$> ( flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
|
||||
<|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
|
||||
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
|
||||
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc-assignment" <> help "Output JSON table of contents diff summary using the assignment parser") )
|
||||
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc-assignment" <> help "Output JSON table of contents diff summary using the assignment parser")
|
||||
<|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph"))
|
||||
<*> ( Right <$> some (both
|
||||
<$> argument filePathReader (metavar "FILE_A")
|
||||
<*> argument filePathReader (metavar "FILE_B"))
|
||||
@ -76,7 +77,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
<$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
|
||||
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
|
||||
<|> flag' (SomeRenderer ToCTermRenderer) (long "toc" <> help "Output JSON table of contents summary")
|
||||
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols"))
|
||||
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags/symbols")
|
||||
<|> flag' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output the term as a DOT graph"))
|
||||
<*> ( Right <$> some (argument filePathReader (metavar "FILES..."))
|
||||
<|> pure (Left stdin) )
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user