mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
WIP - new renderer achitecture
This commit is contained in:
Timothy Clem
parent
5870b33b51
commit
389bfaf220
@ -20,7 +20,6 @@ library
|
||||
, Command
|
||||
, Command.Files
|
||||
, Command.Git
|
||||
, Command.Parse
|
||||
, Data.Align.Generic
|
||||
, Data.Functor.Both
|
||||
, Data.Functor.Classes.Eq.Generic
|
||||
@ -149,7 +148,6 @@ test-suite test
|
||||
other-modules: AlignmentSpec
|
||||
, Command.Spec
|
||||
, Command.Diff.Spec
|
||||
, Command.Parse.Spec
|
||||
, Data.Mergeable.Spec
|
||||
, Data.RandomWalkSimilarity.Spec
|
||||
, Data.Syntax.Assignment.Spec
|
||||
|
||||
@ -1,38 +1,66 @@
|
||||
{-# LANGUAGE GADTs, DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs, DuplicateRecordFields, RankNTypes #-}
|
||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||
module Arguments where
|
||||
|
||||
import Command
|
||||
import Data.Maybe
|
||||
import Prelude
|
||||
import Prologue
|
||||
import Renderer
|
||||
import Renderer.SExpression
|
||||
import Info
|
||||
|
||||
|
||||
data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath
|
||||
deriving Show
|
||||
|
||||
data DiffArguments = DiffArguments
|
||||
{ encodeDiff :: DiffEncoder
|
||||
, diffMode :: DiffMode
|
||||
, gitDir :: FilePath
|
||||
, alternateObjectDirs :: [FilePath]
|
||||
} deriving Show
|
||||
data DiffArguments where
|
||||
DiffArguments :: (Monoid output, StringConv output ByteString) =>
|
||||
{ diffRenderer :: DiffRenderer DefaultFields output
|
||||
, diffMode :: DiffMode
|
||||
, gitDir :: FilePath
|
||||
, alternateObjectDirs :: [FilePath]
|
||||
} -> DiffArguments
|
||||
-- deriving Show
|
||||
|
||||
patchDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
patchDiff = DiffArguments PatchRenderer
|
||||
|
||||
splitDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
splitDiff = DiffArguments SplitRenderer
|
||||
|
||||
jsonDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
jsonDiff = DiffArguments JSONDiffRenderer
|
||||
|
||||
summaryDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
summaryDiff = DiffArguments SummaryRenderer
|
||||
|
||||
sExpressionDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
sExpressionDiff = DiffArguments (SExpressionDiffRenderer TreeOnly)
|
||||
|
||||
tocDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
|
||||
tocDiff = DiffArguments ToCRenderer
|
||||
|
||||
|
||||
data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath]
|
||||
deriving Show
|
||||
|
||||
data ParseArguments = ParseArguments
|
||||
{ parseTreeFormat :: DefaultParseTreeRenderer
|
||||
, parseMode :: ParseMode
|
||||
, debug :: Bool
|
||||
, gitDir :: FilePath
|
||||
, alternateObjectDirs :: [FilePath]
|
||||
} deriving Show
|
||||
data ParseArguments where
|
||||
ParseArguments :: (Monoid output, StringConv output ByteString) =>
|
||||
{ parseTreeRenderer :: ParseTreeRenderer DefaultFields output
|
||||
, parseMode :: ParseMode
|
||||
, debug :: Bool
|
||||
, gitDir :: FilePath
|
||||
, alternateObjectDirs :: [FilePath]
|
||||
} -> ParseArguments
|
||||
-- deriving Show
|
||||
|
||||
sExpressionParseTree :: ParseMode -> Bool -> FilePath -> [FilePath] -> ParseArguments
|
||||
sExpressionParseTree = ParseArguments (SExpressionParseTreeRenderer TreeOnly)
|
||||
|
||||
data ProgramMode = Parse ParseArguments | Diff DiffArguments
|
||||
deriving Show
|
||||
-- deriving Show
|
||||
|
||||
data Arguments = Arguments
|
||||
{ programMode :: ProgramMode
|
||||
, outputFilePath :: Maybe FilePath
|
||||
} deriving Show
|
||||
} -- deriving Show
|
||||
|
||||
@ -11,13 +11,13 @@ module Command
|
||||
, maybeDiff
|
||||
, renderDiffs
|
||||
, concurrently
|
||||
, patchDiff
|
||||
, splitDiff
|
||||
, jsonDiff
|
||||
, summaryDiff
|
||||
, sExpressionDiff
|
||||
, tocDiff
|
||||
, DiffEncoder
|
||||
-- , patchDiff
|
||||
-- , splitDiff
|
||||
-- , jsonDiff
|
||||
-- , summaryDiff
|
||||
-- , sExpressionDiff
|
||||
-- , tocDiff
|
||||
-- , DiffEncoder
|
||||
-- , ParseTreeEncoder
|
||||
-- Evaluation
|
||||
, runCommand
|
||||
@ -103,7 +103,7 @@ maybeDiff terms = case runJoin terms of
|
||||
(Nothing, Nothing) -> return Nothing
|
||||
|
||||
-- | Render a diff using the specified renderer.
|
||||
renderDiffs :: (NFData (Record fields), Monoid output) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> Command output
|
||||
renderDiffs :: (NFData (Record fields), Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> Command output
|
||||
renderDiffs renderer diffs = RenderDiffs renderer (diffs `using` parTraversable (parTuple2 r0 rdeepseq)) `Then` return
|
||||
|
||||
-- | Run a function over each element of a Traversable concurrently.
|
||||
@ -137,7 +137,7 @@ data CommandF f where
|
||||
|
||||
Diff :: HasField fields Category => Both (Term (Syntax Text) (Record fields)) -> CommandF (Diff (Syntax Text) (Record fields))
|
||||
|
||||
RenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> CommandF output
|
||||
RenderDiffs :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> CommandF output
|
||||
|
||||
Concurrently :: Traversable t => t a -> (a -> Command b) -> CommandF (t b)
|
||||
|
||||
@ -200,40 +200,40 @@ runDiff terms = stripDiff (runBothWith diffTerms (fmap decorate terms))
|
||||
Leaf s -> Just s
|
||||
_ -> Nothing)
|
||||
|
||||
runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
|
||||
runRenderDiffs :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
|
||||
runRenderDiffs = runDiffRenderer
|
||||
|
||||
|
||||
-- type ParseTreeEncoder = Bool -> [Term (Syntax Text) (Record DefaultFields)] -> Command ByteString
|
||||
|
||||
type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
|
||||
-- type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
|
||||
|
||||
patchDiff :: DiffEncoder
|
||||
patchDiff = fmap encodeText . renderDiffs R.PatchRenderer
|
||||
-- patchDiff :: DiffEncoder
|
||||
-- patchDiff = fmap encodeText . renderDiffs R.PatchRenderer
|
||||
--
|
||||
-- splitDiff :: DiffEncoder
|
||||
-- splitDiff = fmap encodeText . renderDiffs R.SplitRenderer
|
||||
--
|
||||
-- jsonDiff :: DiffEncoder
|
||||
-- jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer
|
||||
|
||||
splitDiff :: DiffEncoder
|
||||
splitDiff = fmap encodeText . renderDiffs R.SplitRenderer
|
||||
-- summaryDiff :: DiffEncoder
|
||||
-- summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer
|
||||
|
||||
jsonDiff :: DiffEncoder
|
||||
jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer
|
||||
-- sExpressionDiff :: DiffEncoder
|
||||
-- sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
|
||||
|
||||
summaryDiff :: DiffEncoder
|
||||
summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer
|
||||
-- tocDiff :: DiffEncoder
|
||||
-- tocDiff = fmap encodeSummaries . renderDiffs R.ToCRenderer
|
||||
|
||||
sExpressionDiff :: DiffEncoder
|
||||
sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
|
||||
-- encodeJSON :: Map Text Value -> ByteString
|
||||
-- encodeJSON = toS . (<> "\n") . encode
|
||||
--
|
||||
-- encodeText :: File -> ByteString
|
||||
-- encodeText = encodeUtf8 . R.unFile
|
||||
|
||||
tocDiff :: DiffEncoder
|
||||
tocDiff = fmap encodeSummaries . renderDiffs R.ToCRenderer
|
||||
|
||||
encodeJSON :: Map Text Value -> ByteString
|
||||
encodeJSON = toS . (<> "\n") . encode
|
||||
|
||||
encodeText :: File -> ByteString
|
||||
encodeText = encodeUtf8 . R.unFile
|
||||
|
||||
encodeSummaries :: Summaries -> ByteString
|
||||
encodeSummaries = toS . (<> "\n") . encode
|
||||
-- encodeSummaries :: Summaries -> ByteString
|
||||
-- encodeSummaries = toS . (<> "\n") . encode
|
||||
|
||||
--
|
||||
-- instance Show ParseTreeEncoder where
|
||||
@ -244,17 +244,18 @@ encodeSummaries = toS . (<> "\n") . encode
|
||||
-- \/ cons0 jsonIndexParseTree
|
||||
-- \/ cons0 sExpressionParseTree
|
||||
|
||||
instance Show DiffEncoder where
|
||||
showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "
|
||||
. showsPrec 10 (encodeDiff []) . showChar ' '
|
||||
-- instance Show DiffEncoder where
|
||||
-- showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "
|
||||
-- . showsPrec 10 (encodeDiff []) . showChar ' '
|
||||
|
||||
instance Listable DiffEncoder where
|
||||
tiers = cons0 patchDiff
|
||||
\/ cons0 splitDiff
|
||||
\/ cons0 jsonDiff
|
||||
\/ cons0 summaryDiff
|
||||
\/ cons0 sExpressionDiff
|
||||
\/ cons0 tocDiff
|
||||
-- instance Listable DiffEncoder where
|
||||
-- tiers = cons0
|
||||
-- tiers = cons0 patchDiff
|
||||
-- \/ cons0 splitDiff
|
||||
-- \/ cons0 jsonDiff
|
||||
-- \/ cons0 summaryDiff
|
||||
-- \/ cons0 sExpressionDiff
|
||||
-- \/ cons0 tocDiff
|
||||
|
||||
instance MonadIO Command where
|
||||
liftIO io = LiftIO io `Then` return
|
||||
|
||||
@ -1,117 +0,0 @@
|
||||
{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
||||
module Command.Parse
|
||||
( jsonParseTree
|
||||
, jsonIndexParseTree
|
||||
, sExpressionParseTree
|
||||
) where
|
||||
|
||||
import Category
|
||||
import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
|
||||
import Data.Aeson.Types (Pair)
|
||||
import Data.Functor.Foldable hiding (Nil)
|
||||
import Data.Record
|
||||
import Info
|
||||
import Parser
|
||||
import Parser.Language
|
||||
import Prologue
|
||||
import Source
|
||||
import Syntax
|
||||
import Term
|
||||
import Renderer.JSON()
|
||||
import Renderer.SExpression
|
||||
|
||||
|
||||
data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose ParseNode } deriving (Show)
|
||||
|
||||
data Rose a = Rose a [Rose a]
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON ParseTreeFile where
|
||||
toJSON ParseTreeFile{..} = object [ "filePath" .= parseTreeFilePath, "programNode" .= cata algebra node ]
|
||||
where algebra (RoseF a as) = object $ parseNodeToJSONFields a <> [ "children" .= as ]
|
||||
|
||||
|
||||
data IndexFile = IndexFile { indexFilePath :: FilePath, nodes :: [ParseNode] } deriving (Show)
|
||||
|
||||
instance ToJSON IndexFile where
|
||||
toJSON IndexFile{..} = object [ "filePath" .= indexFilePath, "programNodes" .= foldMap (singleton . object . parseNodeToJSONFields) nodes ]
|
||||
where singleton a = [a]
|
||||
|
||||
data ParseNode = ParseNode
|
||||
{ category :: Text
|
||||
, sourceRange :: Range
|
||||
, sourceText :: Maybe SourceText
|
||||
, sourceSpan :: SourceSpan
|
||||
, identifier :: Maybe Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Produce a list of JSON 'Pair's for the fields in a given ParseNode.
|
||||
parseNodeToJSONFields :: ParseNode -> [Pair]
|
||||
parseNodeToJSONFields ParseNode{..} =
|
||||
[ "category" .= category, "sourceRange" .= sourceRange, "sourceSpan" .= sourceSpan ]
|
||||
<> [ "sourceText" .= sourceText | isJust sourceText ]
|
||||
<> [ "identifier" .= identifier | isJust identifier ]
|
||||
|
||||
|
||||
-- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON.
|
||||
jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString
|
||||
jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose
|
||||
|
||||
-- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
|
||||
jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString
|
||||
jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : concat siblings)
|
||||
|
||||
-- | Parses file contents into an SExpression format for the provided arguments.
|
||||
sExpressionParseTree :: Bool -> [SourceBlob] -> IO ByteString
|
||||
sExpressionParseTree _ blobs =
|
||||
pure . printTerms TreeOnly =<< parse blobs
|
||||
where parse = traverse (\sourceBlob@SourceBlob{..} -> parserForFilePath path sourceBlob)
|
||||
|
||||
parseRoot :: Bool -> (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> [SourceBlob] -> IO [root]
|
||||
parseRoot debug construct combine blobs = for blobs (\ sourceBlob@SourceBlob{..} -> do
|
||||
parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
|
||||
pure $! construct path (para algebra parsedTerm))
|
||||
where algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
|
||||
decorator = parseDecorator debug
|
||||
makeNode :: Record (Maybe SourceText ': DefaultFields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': DefaultFields))) -> ParseNode
|
||||
makeNode (head :. range :. category :. sourceSpan :. Nil) syntax =
|
||||
ParseNode (toS category) range head sourceSpan (identifierFor syntax)
|
||||
|
||||
-- | Determines the term decorator to use when parsing.
|
||||
parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText))
|
||||
parseDecorator True = termSourceTextDecorator
|
||||
parseDecorator False = const . const Nothing
|
||||
|
||||
-- | Returns a Just identifier text if the given Syntax term contains an identifier (leaf) syntax. Otherwise returns Nothing.
|
||||
identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
|
||||
identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier
|
||||
|
||||
-- | Return a parser incorporating the provided TermDecorator.
|
||||
parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record (field ': DefaultFields))
|
||||
parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForFilePath path blob
|
||||
|
||||
-- | Decorate a 'Term' using a function to compute the annotation values at every node.
|
||||
decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
|
||||
decorateTerm decorator = cata $ \ term -> cofree ((decorator term :. headF term) :< tailF term)
|
||||
|
||||
-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms.
|
||||
type TermDecorator f fields field = TermF f (Record fields) (Term f (Record (field ': fields))) -> field
|
||||
|
||||
-- | Term decorator extracting the source text for a term.
|
||||
termSourceTextDecorator :: (Functor f, HasField fields Range) => Source -> TermDecorator f fields (Maybe SourceText)
|
||||
termSourceTextDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source)))
|
||||
|
||||
newtype Identifier = Identifier Text
|
||||
deriving (Eq, Show, ToJSON)
|
||||
|
||||
data RoseF a b = RoseF a [b]
|
||||
deriving (Eq, Functor, Show)
|
||||
|
||||
type instance Base (Rose a) = RoseF a
|
||||
|
||||
instance Recursive (Rose a) where
|
||||
project (Rose a tree) = RoseF a tree
|
||||
|
||||
instance Corecursive (Rose a) where
|
||||
embed (RoseF a tree) = Rose a tree
|
||||
@ -1,8 +1,8 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GADTs, MultiParamTypeClasses #-}
|
||||
module Renderer
|
||||
( DiffRenderer(..)
|
||||
, runDiffRenderer
|
||||
, DefaultParseTreeRenderer
|
||||
-- , DefaultParseTreeRenderer
|
||||
, ParseTreeRenderer(..)
|
||||
, runParseTreeRenderer
|
||||
, Summaries(..)
|
||||
@ -29,6 +29,7 @@ import Syntax
|
||||
import Term
|
||||
import Data.Functor.Listable
|
||||
|
||||
|
||||
data DiffRenderer fields output where
|
||||
SplitRenderer :: (HasField fields Category, HasField fields Range) => DiffRenderer fields File
|
||||
PatchRenderer :: HasField fields Range => DiffRenderer fields File
|
||||
@ -37,7 +38,7 @@ data DiffRenderer fields output where
|
||||
SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> DiffRenderer fields ByteString
|
||||
ToCRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries
|
||||
|
||||
runDiffRenderer :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
|
||||
runDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
|
||||
runDiffRenderer renderer = foldMap . uncurry $ case renderer of
|
||||
SplitRenderer -> (File .) . R.split
|
||||
PatchRenderer -> (File .) . R.patch
|
||||
@ -46,21 +47,22 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
|
||||
SExpressionDiffRenderer format -> R.sExpression format
|
||||
ToCRenderer -> R.toc
|
||||
|
||||
|
||||
type DefaultParseTreeRenderer = ParseTreeRenderer DefaultFields ByteString
|
||||
|
||||
data ParseTreeRenderer fields output where
|
||||
SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString
|
||||
-- JSONParseTreeRenderer :: ParseTreeRenderer ParseTreeFile
|
||||
|
||||
runParseTreeRenderer :: Monoid output => ParseTreeRenderer fields output -> [Term (Syntax Text) (Record fields)] -> output
|
||||
runParseTreeRenderer renderer = foldMap $ case renderer of
|
||||
SExpressionParseTreeRenderer format -> printTerm format
|
||||
where
|
||||
printTerm format term = R.printTerm term 0 format
|
||||
runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> output
|
||||
runParseTreeRenderer renderer = foldMap . uncurry $ case renderer of
|
||||
SExpressionParseTreeRenderer format -> R.sExpressionParseTree format
|
||||
-- where
|
||||
-- printTerm format term = R.printTerm term 0 format
|
||||
|
||||
newtype File = File { unFile :: Text }
|
||||
deriving Show
|
||||
|
||||
instance StringConv File ByteString where
|
||||
strConv _ = encodeUtf8 . unFile
|
||||
|
||||
instance Show (DiffRenderer fields output) where
|
||||
showsPrec _ SplitRenderer = showString "SplitRenderer"
|
||||
showsPrec _ PatchRenderer = showString "PatchRenderer"
|
||||
@ -71,10 +73,12 @@ instance Show (DiffRenderer fields output) where
|
||||
|
||||
instance Show (ParseTreeRenderer fields output) where
|
||||
showsPrec d (SExpressionParseTreeRenderer format) = showsUnaryWith showsPrec "SExpressionParseTreeRenderer" d format
|
||||
-- showsPrec _ JSONParseTreeRenderer = showString "JSONParseTreeRenderer"
|
||||
|
||||
instance Monoid File where
|
||||
mempty = File mempty
|
||||
mappend (File a) (File b) = File (a <> "\n" <> b)
|
||||
|
||||
instance Listable DefaultParseTreeRenderer where
|
||||
tiers = cons0 (SExpressionParseTreeRenderer TreeOnly)
|
||||
-- instance Listable ParseTreeRenderer where
|
||||
-- tiers = cons0 (SExpressionParseTreeRenderer TreeOnly)
|
||||
-- \/ cons0 JSONParseTreeRenderer
|
||||
|
||||
@ -1,26 +1,34 @@
|
||||
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Renderer.JSON (
|
||||
json
|
||||
module Renderer.JSON
|
||||
( json
|
||||
, jsonParseTree
|
||||
, ParseTreeFile(..)
|
||||
) where
|
||||
|
||||
import Prologue hiding (toList)
|
||||
import Alignment
|
||||
import Category
|
||||
import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
|
||||
import Data.Aeson as A hiding (json)
|
||||
import Data.Aeson.Types (Pair)
|
||||
import Data.Bifunctor.Join
|
||||
import Data.Functor.Both
|
||||
import Data.Functor.Foldable hiding (Nil)
|
||||
import Data.Record
|
||||
import qualified Data.Text as T
|
||||
import Data.These
|
||||
import Data.Vector as Vector hiding (toList)
|
||||
import Diff
|
||||
import Info
|
||||
import Parser
|
||||
import Parser.Language
|
||||
import Prologue
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import Source
|
||||
import SplitDiff
|
||||
import Syntax as S
|
||||
import Term
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- | Render a diff to a string representing its JSON.
|
||||
json :: (ToJSON (Record fields), HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff (Syntax Text) (Record fields) -> Map Text Value
|
||||
@ -34,6 +42,9 @@ json blobs diff = Map.fromList [
|
||||
-- | A numbered 'a'.
|
||||
newtype NumberedLine a = NumberedLine (Int, a)
|
||||
|
||||
instance StringConv (Map Text Value) ByteString where
|
||||
strConv _ = toS . (<> "\n") . encode
|
||||
|
||||
instance (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitSyntaxDiff leaf fields)) where
|
||||
toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a))
|
||||
toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a))
|
||||
@ -82,7 +93,7 @@ termFields :: (ToJSON recur, KeyValue kv, HasField fields Category, HasField fie
|
||||
Record fields ->
|
||||
Syntax leaf recur ->
|
||||
[kv]
|
||||
termFields info syntax = "range" .= byteRange info : "category" .= category info : syntaxToTermField syntax
|
||||
termFields info syntax = "range" .= byteRange info : "category" .= Info.category info : syntaxToTermField syntax
|
||||
|
||||
patchFields :: (ToJSON (Record fields), ToJSON leaf, KeyValue kv, HasField fields Category, HasField fields Range) =>
|
||||
SplitPatch (SyntaxTerm leaf fields) ->
|
||||
@ -156,3 +167,97 @@ syntaxToTermField syntax = case syntax of
|
||||
S.Ty ty -> [ "type" .= ty ]
|
||||
S.Send channel expr -> [ "channel" .= channel ] <> [ "expression" .= expr ]
|
||||
where childrenFields c = [ "children" .= c ]
|
||||
|
||||
|
||||
--
|
||||
data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose ParseNode } deriving (Show)
|
||||
|
||||
data Rose a = Rose a [Rose a]
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON ParseTreeFile where
|
||||
toJSON ParseTreeFile{..} = object [ "filePath" .= parseTreeFilePath, "programNode" .= cata algebra node ]
|
||||
where algebra (RoseF a as) = object $ parseNodeToJSONFields a <> [ "children" .= as ]
|
||||
|
||||
|
||||
data IndexFile = IndexFile { indexFilePath :: FilePath, nodes :: [ParseNode] } deriving (Show)
|
||||
|
||||
instance ToJSON IndexFile where
|
||||
toJSON IndexFile{..} = object [ "filePath" .= indexFilePath, "programNodes" .= foldMap (singleton . object . parseNodeToJSONFields) nodes ]
|
||||
where singleton a = [a]
|
||||
|
||||
data ParseNode = ParseNode
|
||||
{ category :: Text
|
||||
, sourceRange :: Range
|
||||
, sourceText :: Maybe SourceText
|
||||
, sourceSpan :: SourceSpan
|
||||
, identifier :: Maybe Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | Produce a list of JSON 'Pair's for the fields in a given ParseNode.
|
||||
parseNodeToJSONFields :: ParseNode -> [Pair]
|
||||
parseNodeToJSONFields ParseNode{..} =
|
||||
[ "category" .= category, "sourceRange" .= sourceRange, "sourceSpan" .= sourceSpan ]
|
||||
<> [ "sourceText" .= sourceText | isJust sourceText ]
|
||||
<> [ "identifier" .= identifier | isJust identifier ]
|
||||
|
||||
|
||||
jsonParseTree :: Bool -> SourceBlob -> ByteString
|
||||
jsonParseTree = undefined
|
||||
|
||||
-- -- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON.
|
||||
-- jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString
|
||||
-- jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose
|
||||
--
|
||||
-- -- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
|
||||
-- jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString
|
||||
-- jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : Prologue.concat siblings)
|
||||
|
||||
parseRoot :: Bool -> (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> [SourceBlob] -> IO [root]
|
||||
parseRoot debug construct combine blobs = for blobs (\ sourceBlob@SourceBlob{..} -> do
|
||||
parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
|
||||
pure $! construct path (para algebra parsedTerm))
|
||||
where algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
|
||||
decorator = parseDecorator debug
|
||||
makeNode :: Record (Maybe SourceText ': DefaultFields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': DefaultFields))) -> ParseNode
|
||||
makeNode (head :. range :. category :. sourceSpan :. Nil) syntax =
|
||||
ParseNode (toS category) range head sourceSpan (identifierFor syntax)
|
||||
|
||||
-- | Determines the term decorator to use when parsing.
|
||||
parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText))
|
||||
parseDecorator True = termSourceTextDecorator
|
||||
parseDecorator False = const . const Nothing
|
||||
|
||||
-- | Returns a Just identifier text if the given Syntax term contains an identifier (leaf) syntax. Otherwise returns Nothing.
|
||||
identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
|
||||
identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier
|
||||
|
||||
-- | Return a parser incorporating the provided TermDecorator.
|
||||
parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record (field ': DefaultFields))
|
||||
parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForFilePath path blob
|
||||
|
||||
-- | Decorate a 'Term' using a function to compute the annotation values at every node.
|
||||
decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
|
||||
decorateTerm decorator = cata $ \ term -> cofree ((decorator term :. headF term) :< tailF term)
|
||||
|
||||
-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms.
|
||||
type TermDecorator f fields field = TermF f (Record fields) (Term f (Record (field ': fields))) -> field
|
||||
|
||||
-- | Term decorator extracting the source text for a term.
|
||||
termSourceTextDecorator :: (Functor f, HasField fields Range) => Source -> TermDecorator f fields (Maybe SourceText)
|
||||
termSourceTextDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source)))
|
||||
|
||||
newtype Identifier = Identifier Text
|
||||
deriving (Eq, Show, ToJSON)
|
||||
|
||||
data RoseF a b = RoseF a [b]
|
||||
deriving (Eq, Functor, Show)
|
||||
|
||||
type instance Base (Rose a) = RoseF a
|
||||
|
||||
instance Recursive (Rose a) where
|
||||
project (Rose a tree) = RoseF a tree
|
||||
|
||||
instance Corecursive (Rose a) where
|
||||
embed (RoseF a tree) = Rose a tree
|
||||
|
||||
@ -1,5 +1,11 @@
|
||||
{-# LANGUAGE RankNTypes, ScopedTypeVariables, OverloadedStrings #-}
|
||||
module Renderer.SExpression (sExpression, printTerm, printTerms, SExpressionFormat(..)) where
|
||||
module Renderer.SExpression
|
||||
( sExpression
|
||||
, sExpressionParseTree
|
||||
, printTerm
|
||||
, printTerms
|
||||
, SExpressionFormat(..)
|
||||
) where
|
||||
|
||||
import Data.Bifunctor.Join
|
||||
import Data.ByteString hiding (foldr, spanEnd)
|
||||
@ -17,9 +23,14 @@ import Term
|
||||
data SExpressionFormat = TreeOnly | TreeAndRanges
|
||||
deriving (Show)
|
||||
|
||||
-- | ByteString SExpression formatted diff.
|
||||
sExpression :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> Both SourceBlob -> Diff (Syntax Text) (Record fields) -> ByteString
|
||||
sExpression format _ diff = printDiff diff 0 format
|
||||
|
||||
-- | ByteString SExpression formatted term.
|
||||
sExpressionParseTree :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> SourceBlob -> Term (Syntax Text) (Record fields) -> ByteString
|
||||
sExpressionParseTree format _ term = printTerm term 0 format
|
||||
|
||||
printDiff :: (HasField fields Category, HasField fields SourceSpan) => Diff (Syntax Text) (Record fields) -> Int -> SExpressionFormat -> ByteString
|
||||
printDiff diff level format = case runFree diff of
|
||||
(Pure patch) -> case patch of
|
||||
|
||||
@ -36,7 +36,7 @@ instance Monoid Summaries where
|
||||
mempty = Summaries mempty mempty
|
||||
mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
|
||||
|
||||
instance (StringConv Summaries ByteString) where
|
||||
instance StringConv Summaries ByteString where
|
||||
strConv _ = toS . (<> "\n") . encode
|
||||
|
||||
instance ToJSON Summaries where
|
||||
|
||||
@ -47,8 +47,12 @@ diffBlobs' blobs = do
|
||||
-- | Parse a list of blobs and use the specified renderer to produce ByteString output.
|
||||
parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString
|
||||
parseBlobs renderer blobs = do
|
||||
terms <- traverse parseBlob' blobs
|
||||
pure . toS $ runParseTreeRenderer renderer (terms `using` parTraversable rdeepseq)
|
||||
terms <- traverse go blobs
|
||||
pure . toS $ runParseTreeRenderer renderer terms
|
||||
where
|
||||
go blob = do
|
||||
terms <- parseBlob' blob
|
||||
pure (blob, terms)
|
||||
|
||||
-- | Parse a SourceBlob.
|
||||
parseBlob' :: SourceBlob -> IO (Term (Syntax Text) (Record DefaultFields))
|
||||
|
||||
@ -5,7 +5,6 @@ import Arguments
|
||||
import Command
|
||||
import Command.Files
|
||||
import Command.Git
|
||||
import Command.Parse
|
||||
import Data.Functor.Both
|
||||
import Data.List.Split (splitWhen)
|
||||
import Data.String
|
||||
@ -17,7 +16,7 @@ import qualified Data.ByteString as B
|
||||
import qualified Paths_semantic_diff as Library (version)
|
||||
import Source
|
||||
import Renderer
|
||||
import Renderer.SExpression
|
||||
-- import Renderer.SExpression
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath.Posix (takeFileName, (-<.>))
|
||||
@ -35,7 +34,6 @@ main = do
|
||||
Diff args -> runDiff args
|
||||
Parse args -> runParse args
|
||||
writeToOutput outputPath text
|
||||
|
||||
where
|
||||
findGitDir = do
|
||||
pwd <- getCurrentDirectory
|
||||
@ -70,16 +68,14 @@ runDiff DiffArguments{..} = runCommand $ do
|
||||
terms <- concurrently blobs (traverse parseBlob)
|
||||
diff' <- maybeDiff terms
|
||||
pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
|
||||
encodeDiff (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
|
||||
pure . toS $ runDiffRenderer diffRenderer (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
|
||||
|
||||
runParse :: ParseArguments -> IO ByteString
|
||||
runParse ParseArguments{..} = do
|
||||
blobs <- case parseMode of
|
||||
ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
|
||||
ParsePaths paths -> sourceBlobsFromPaths paths
|
||||
Semantic.parseBlobs parseTreeFormat blobs
|
||||
-- toS $ runParseTreeRenderer renderParseTree blobs
|
||||
-- renderParseTree debug blobs
|
||||
Semantic.parseBlobs parseTreeRenderer blobs
|
||||
|
||||
-- | A parser for the application's command-line arguments.
|
||||
arguments :: FilePath -> [FilePath] -> ParserInfo Arguments
|
||||
@ -96,27 +92,25 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc
|
||||
|
||||
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
|
||||
diffArgumentsParser = Diff
|
||||
<$> ( DiffArguments
|
||||
<$> ( flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
|
||||
<|> flag' splitDiff (long "split" <> help "Output a split diff")
|
||||
<|> flag' jsonDiff (long "json" <> help "Output a json diff")
|
||||
<|> flag' summaryDiff (long "summary" <> help "Output a diff summary")
|
||||
<|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree")
|
||||
<|> flag' tocDiff (long "toc" <> help "Output a table of contents diff summary") )
|
||||
<*> ( DiffPaths
|
||||
<$> argument str (metavar "FILE_A")
|
||||
<*> argument str (metavar "FILE_B")
|
||||
<|> DiffCommits
|
||||
<$> option (eitherReader parseSha) (long "sha1" <> metavar "SHA" <> help "Starting commit SHA")
|
||||
<*> option (eitherReader parseSha) (long "sha2" <> metavar "SHA" <> help "Ending commit SHA")
|
||||
<*> many (argument str (metavar "FILES...")) )
|
||||
<*> pure gitDir
|
||||
<*> pure alternates )
|
||||
<$> ( ( flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
|
||||
<|> flag' splitDiff (long "split" <> help "Output a split diff")
|
||||
<|> flag' jsonDiff (long "json" <> help "Output a json diff")
|
||||
<|> flag' summaryDiff (long "summary" <> help "Output a diff summary")
|
||||
<|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree")
|
||||
<|> flag' tocDiff (long "toc" <> help "Output a table of contents diff summary") )
|
||||
<*> ( DiffPaths
|
||||
<$> argument str (metavar "FILE_A")
|
||||
<*> argument str (metavar "FILE_B")
|
||||
<|> DiffCommits
|
||||
<$> option (eitherReader parseSha) (long "sha1" <> metavar "SHA" <> help "Starting commit SHA")
|
||||
<*> option (eitherReader parseSha) (long "sha2" <> metavar "SHA" <> help "Ending commit SHA")
|
||||
<*> many (argument str (metavar "FILES...")) )
|
||||
<*> pure gitDir
|
||||
<*> pure alternates )
|
||||
|
||||
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths"))
|
||||
parseArgumentsParser = Parse
|
||||
<$> ( ParseArguments
|
||||
<$> ( flag (SExpressionParseTreeRenderer TreeOnly) (SExpressionParseTreeRenderer TreeOnly) (long "sexpression" <> help "Output s-expression parse trees (default)") )
|
||||
<$> ( ( flag sExpressionParseTree sExpressionParseTree (long "sexpression" <> help "Output s-expression parse trees (default)") )
|
||||
-- <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees")
|
||||
-- <|> flag' jsonIndexParseTree (long "index" <> help "Output JSON parse trees in index format") )
|
||||
<*> ( ParsePaths
|
||||
|
||||
@ -1,21 +0,0 @@
|
||||
module Command.Parse.Spec where
|
||||
|
||||
import Command.Files
|
||||
import Command.Parse
|
||||
import Control.Monad
|
||||
import Prelude
|
||||
import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
|
||||
import Test.Hspec.Expectations.Pretty
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel . context "parse" $ do
|
||||
let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
it "should produce s-expression trees" $ do
|
||||
output <- sExpressionParseTree False =<< blobs
|
||||
output `shouldNotBe` ""
|
||||
it "should produce JSON trees" $ do
|
||||
output <- jsonParseTree False =<< blobs
|
||||
output `shouldNotBe` ""
|
||||
it "should produce JSON index" $ do
|
||||
output <- jsonIndexParseTree False =<< blobs
|
||||
output `shouldNotBe` ""
|
||||
@ -1,11 +1,14 @@
|
||||
module Command.Spec where
|
||||
|
||||
import Command
|
||||
import Command.Files
|
||||
import Data.Functor.Both
|
||||
import Data.String
|
||||
import Language
|
||||
import Prologue hiding (readFile)
|
||||
import Source
|
||||
import Renderer.JSON
|
||||
import Renderer.SExpression
|
||||
import Syntax
|
||||
import Test.Hspec
|
||||
|
||||
@ -42,6 +45,21 @@ spec = parallel $ do
|
||||
term <- runCommand (parse (Just Ruby) methodsBlob)
|
||||
fmap (const ()) term `shouldBe` cofree (() :< Indexed [ cofree (() :< Method [] (cofree (() :< Leaf "foo")) Nothing [] []) ])
|
||||
|
||||
-- TODO
|
||||
-- let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
-- it "should produce s-expression trees" $ do
|
||||
-- blobs <- sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
-- let output = foldMap (sExpressionParseTree TreeOnly) blobs
|
||||
-- output `shouldNotBe` ""
|
||||
|
||||
-- it "should produce JSON trees" $ do
|
||||
-- output <- jsonParseTree False =<< blobs
|
||||
-- output `shouldNotBe` ""
|
||||
--
|
||||
-- it "should produce JSON index" $ do
|
||||
-- output <- jsonIndexParseTree False =<< blobs
|
||||
-- output `shouldNotBe` ""
|
||||
|
||||
where repoPath = "test/fixtures/git/examples/all-languages.git"
|
||||
methodsFixture = Fixture
|
||||
(both "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe")
|
||||
|
||||
@ -9,15 +9,19 @@ import Test.Hspec.LeanCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "runDiff" $ do
|
||||
prop "produces diffs for all formats" $
|
||||
\ encoder -> do
|
||||
let mode = DiffPaths "test/fixtures/ruby/and-or.A.rb" "test/fixtures/ruby/and-or.B.rb"
|
||||
output <- runDiff $ DiffArguments encoder mode "" []
|
||||
output `shouldNotBe` ""
|
||||
-- describe "runDiff" $ do
|
||||
-- prop "produces diffs for all formats" $
|
||||
-- \ encoder -> do
|
||||
-- let mode = DiffPaths "test/fixtures/ruby/and-or.A.rb" "test/fixtures/ruby/and-or.B.rb"
|
||||
-- output <- runDiff $ DiffArguments encoder mode "" []
|
||||
-- output `shouldNotBe` ""
|
||||
describe "runParse" $ do
|
||||
prop "produces parse trees for all formats" $
|
||||
\ renderer -> do
|
||||
let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
output <- runParse $ ParseArguments renderer mode False "" []
|
||||
output `shouldNotBe` ""
|
||||
it "sExpression" $ do
|
||||
let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
output <- runParse $ sExpressionParseTree mode False "" []
|
||||
output `shouldNotBe` ""
|
||||
-- prop "produces parse trees for all formats" $
|
||||
-- \ renderer -> do
|
||||
-- let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
|
||||
-- output <- runParse $ ParseArguments renderer mode False "" []
|
||||
-- output `shouldNotBe` ""
|
||||
|
||||
@ -4,7 +4,6 @@ import Prologue
|
||||
import qualified AlignmentSpec
|
||||
import qualified Command.Spec
|
||||
import qualified Command.Diff.Spec
|
||||
import qualified Command.Parse.Spec
|
||||
import qualified Data.Mergeable.Spec
|
||||
import qualified Data.RandomWalkSimilarity.Spec
|
||||
import qualified Data.Syntax.Assignment.Spec
|
||||
@ -28,7 +27,6 @@ main = hspec $ do
|
||||
describe "Alignment" AlignmentSpec.spec
|
||||
describe "Command" Command.Spec.spec
|
||||
describe "Command.Diff" Command.Diff.Spec.spec
|
||||
describe "Command.Parse" Command.Parse.Spec.spec
|
||||
describe "Data.Mergeable" Data.Mergeable.Spec.spec
|
||||
describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
|
||||
describe "Data.Syntax.Assignment" Data.Syntax.Assignment.Spec.spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user