diff --git a/semantic-diff.cabal b/semantic-diff.cabal index c08b9255f..af12cde6a 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -146,8 +146,7 @@ test-suite test hs-source-dirs: test main-is: Spec.hs other-modules: AlignmentSpec - , Command.Spec - , Command.Diff.Spec + , CommandSpec , Data.Mergeable.Spec , Data.RandomWalkSimilarity.Spec , Data.Syntax.Assignment.Spec diff --git a/src/Arguments.hs b/src/Arguments.hs index b90c91180..a887d54e6 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, DuplicateRecordFields, RankNTypes #-} +{-# LANGUAGE GADTs, DuplicateRecordFields, RankNTypes, ViewPatterns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Arguments where @@ -20,7 +20,6 @@ data DiffArguments where , gitDir :: FilePath , alternateObjectDirs :: [FilePath] } -> DiffArguments - -- deriving Show patchDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments patchDiff = DiffArguments PatchRenderer @@ -52,15 +51,36 @@ data ParseArguments where , gitDir :: FilePath , alternateObjectDirs :: [FilePath] } -> ParseArguments - -- deriving Show sExpressionParseTree :: ParseMode -> Bool -> FilePath -> [FilePath] -> ParseArguments sExpressionParseTree = ParseArguments (SExpressionParseTreeRenderer TreeOnly) +jsonParseTree :: ParseMode -> Bool -> FilePath -> [FilePath] -> ParseArguments +jsonParseTree = ParseArguments JSONParseTreeRenderer + +jsonIndexParseTree :: ParseMode -> Bool -> FilePath -> [FilePath] -> ParseArguments +jsonIndexParseTree = ParseArguments JSONIndexParseTreeRenderer + data ProgramMode = Parse ParseArguments | Diff DiffArguments - -- deriving Show + deriving Show data Arguments = Arguments { programMode :: ProgramMode , outputFilePath :: Maybe FilePath - } -- deriving Show + } deriving Show + + +instance Show DiffArguments where + showsPrec d (DiffArguments renderer mode gitDir alternateObjectDirs) = showParen (d >= 10) $ showString "DiffArguments " + . showString "diffRenderer = " . shows renderer . showString ", " + . showString "diffMode = " . shows mode . showString ", " + . showString "gitDir = " . shows gitDir . showString ", " + . showString "alternateObjectDirs = " . shows alternateObjectDirs + +instance Show ParseArguments where + showsPrec d (ParseArguments renderer mode debug gitDir alternateObjectDirs) = showParen (d >= 10) $ showString "ParseArguments " + . showString "parseTreeRenderer = " . shows renderer . showString ", " + . showString "parseMode = " . shows mode . showString ", " + . showString "debug = " . shows debug . showString ", " + . showString "gitDir = " . shows gitDir . showString ", " + . showString "alternateObjectDirs = " . shows alternateObjectDirs diff --git a/src/Command.hs b/src/Command.hs index 53742feab..fd2e91df6 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -11,14 +11,6 @@ module Command , maybeDiff , renderDiffs , concurrently --- , patchDiff --- , splitDiff --- , jsonDiff --- , summaryDiff --- , sExpressionDiff --- , tocDiff --- , DiffEncoder --- , ParseTreeEncoder -- Evaluation , runCommand ) where @@ -29,11 +21,9 @@ import Control.Exception (catch) import Control.Monad.Free.Freer import Control.Monad.IO.Class import Control.Parallel.Strategies -import Data.Aeson hiding (json) import qualified Data.ByteString as B import Data.Functor.Both import Data.Functor.Classes -import Data.Functor.Listable import Data.List ((\\), nub) import Data.RandomWalkSimilarity import Data.Record @@ -53,8 +43,6 @@ import Language import Patch import Parser.Language import Prologue hiding (concurrently, Concurrently, readFile) -import qualified Renderer as R -import qualified Renderer.SExpression as R import Renderer import Source import Syntax @@ -204,59 +192,6 @@ runRenderDiffs :: (Monoid output, StringConv output ByteString) => DiffRenderer runRenderDiffs = runDiffRenderer --- type ParseTreeEncoder = Bool -> [Term (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 --- --- splitDiff :: DiffEncoder --- splitDiff = fmap encodeText . renderDiffs R.SplitRenderer --- --- jsonDiff :: DiffEncoder --- jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer - --- summaryDiff :: DiffEncoder --- summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer - --- sExpressionDiff :: DiffEncoder --- sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly) - --- 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 - --- --- instance Show ParseTreeEncoder where --- showsPrec d _ = showParen (d >= 10) $ showString "ParseTreeEncoder " --- -- --- instance Listable ParseTreeEncoder where --- tiers = cons0 jsonParseTree --- \/ cons0 jsonIndexParseTree --- \/ cons0 sExpressionParseTree - --- instance Show DiffEncoder where --- showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder " --- . showsPrec 10 (encodeDiff []) . showChar ' ' - --- 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 diff --git a/src/Info.hs b/src/Info.hs index 1ca73e226..8d703e8eb 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -28,7 +28,7 @@ import Data.Aeson type DefaultFields = '[ Range, Category, SourceSpan ] -- | A type alias for HasField constraints commonly used throughout semantic-diff. -type HasDefaultFields fields = (HasField fields Category, HasField fields Range, HasField fields SourceSpan) +type HasDefaultFields fields = (HasField fields Range, HasField fields Category, HasField fields SourceSpan) newtype SourceText = SourceText { unText :: Text } deriving (Show, ToJSON) diff --git a/src/Renderer.hs b/src/Renderer.hs index 825be6895..e89871c81 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -27,7 +27,6 @@ import Renderer.TOC as R import Source (SourceBlob) import Syntax import Term -import Data.Functor.Listable data DiffRenderer fields output where @@ -49,13 +48,14 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of data ParseTreeRenderer fields output where SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString - -- JSONParseTreeRenderer :: ParseTreeRenderer ParseTreeFile + JSONParseTreeRenderer :: HasDefaultFields fields => ParseTreeRenderer fields Value + JSONIndexParseTreeRenderer :: HasDefaultFields fields => ParseTreeRenderer fields Value 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 + JSONParseTreeRenderer -> R.jsonParseTree False + JSONIndexParseTreeRenderer -> R.jsonIndexParseTree False newtype File = File { unFile :: Text } deriving Show @@ -73,12 +73,14 @@ 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" + showsPrec _ JSONParseTreeRenderer = showString "JSONParseTreeRenderer" + showsPrec _ JSONIndexParseTreeRenderer = showString "JSONIndexParseTreeRenderer" instance Monoid File where mempty = File mempty mappend (File a) (File b) = File (a <> "\n" <> b) --- instance Listable ParseTreeRenderer where +-- instance Listable (ParseTreeRenderer DefaultFields output) where + -- tiers = cons0 (SExpressionParseTreeRenderer TreeOnly) -- tiers = cons0 (SExpressionParseTreeRenderer TreeOnly) -- \/ cons0 JSONParseTreeRenderer diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 014f51c0a..008d8b77d 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -5,13 +5,14 @@ module Renderer.JSON ( json , jsonParseTree +, jsonIndexParseTree , ParseTreeFile(..) ) where import Alignment import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) import Data.Aeson as A hiding (json) -import Data.Aeson.Types (Pair) +import Data.Aeson.Types (Pair, emptyArray) import Data.Bifunctor.Join import Data.Functor.Both import Data.Functor.Foldable hiding (Nil) @@ -20,8 +21,6 @@ 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 @@ -175,10 +174,17 @@ data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose 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 ] +instance Monoid Value where + mempty = emptyArray + mappend a b = A.Array $ Vector.fromList [a, b] + +instance StringConv Value ByteString where + strConv _ = toS . (<> "\n") . encode data IndexFile = IndexFile { indexFilePath :: FilePath, nodes :: [ParseNode] } deriving (Show) @@ -187,7 +193,7 @@ instance ToJSON IndexFile where where singleton a = [a] data ParseNode = ParseNode - { category :: Text + { category :: Category , sourceRange :: Range , sourceText :: Maybe SourceText , sourceSpan :: SourceSpan @@ -198,56 +204,46 @@ data ParseNode = ParseNode -- | 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 ] + [ "category" .= (toS category :: Text), "sourceRange" .= sourceRange, "sourceSpan" .= sourceSpan ] <> [ "sourceText" .= sourceText | isJust sourceText ] <> [ "identifier" .= identifier | isJust identifier ] +jsonParseTree :: HasDefaultFields fields => Bool -> SourceBlob -> Term (Syntax Text) (Record fields) -> Value +jsonParseTree = jsonParseTree' ParseTreeFile Rose -jsonParseTree :: Bool -> SourceBlob -> ByteString -jsonParseTree = undefined +jsonIndexParseTree :: HasDefaultFields fields => Bool -> SourceBlob -> Term (Syntax Text) (Record fields) -> Value +jsonIndexParseTree = jsonParseTree' IndexFile combine + where combine node siblings = node : Prologue.concat siblings --- -- | 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) +jsonParseTree' :: (ToJSON root, HasDefaultFields fields) => (FilePath -> a -> root) -> (ParseNode -> [a] -> a) -> Bool -> SourceBlob -> Term (Syntax Text) (Record fields) -> Value +jsonParseTree' constructor combine debug SourceBlob{..} term = toJSON $ constructor path (para algebra term') + where + term' = decorateTerm (parseDecorator debug source) term + algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax)) -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) + makeNode :: HasDefaultFields fields => Record (Maybe SourceText ': fields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': fields))) -> ParseNode + makeNode (sourceText :. record) syntax = ParseNode (getField record) (getField record) sourceText (getField record) (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 + -- | 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 + -- | 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, HasDefaultFields fields) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) + decorateTerm decorator = cata $ \ term -> cofree ((decorator term :. headF term) :< tailF term) --- | 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) + -- | 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))) -- | 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) diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 4bc149d61..dc8908eec 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -2,8 +2,6 @@ module Renderer.SExpression ( sExpression , sExpressionParseTree -, printTerm -, printTerms , SExpressionFormat(..) ) where @@ -23,11 +21,11 @@ import Term data SExpressionFormat = TreeOnly | TreeAndRanges deriving (Show) --- | ByteString SExpression formatted diff. +-- | Returns a 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. +-- | Returns a 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 @@ -46,8 +44,8 @@ printDiff diff level format = case runFree diff of | n < 1 = "\n" | otherwise = "\n" <> replicate (2 * n) space -printTerms :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> [Term (Syntax t) (Record fields)] -> ByteString -printTerms format terms = foldr (\t acc -> printTerm t 0 format <> acc) "" terms +-- printTerms :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> [Term (Syntax t) (Record fields)] -> ByteString +-- printTerms format terms = foldr (\t acc -> printTerm t 0 format <> acc) "" terms printTerm :: (HasField fields Category, HasField fields SourceSpan) => Term (Syntax t) (Record fields) -> Int -> SExpressionFormat -> ByteString printTerm term level format = go term level 0 diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 792004016..5ad43efe7 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} --- {-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-deprecations #-} -- Disabling deprecation warnings due to pattern match against RescueModifier. module Renderer.Summary (Summaries(..), summary, diffSummaries, DiffSummary(..), DiffInfo(..), diffToDiffSummaries, isBranchInfo, isErrorSummary, JSONSummary(..)) where diff --git a/src/Semantic.hs b/src/Semantic.hs index 6ef7651e8..331676d41 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module Semantic where +import Control.Parallel.Strategies import Data.Functor.Both import Data.RandomWalkSimilarity import Data.Record @@ -12,7 +13,6 @@ import Prologue import Renderer import Source import Syntax -import Control.Parallel.Strategies import Term @@ -48,11 +48,11 @@ diffBlobs' blobs = do parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString parseBlobs renderer blobs = do terms <- traverse go blobs - pure . toS $ runParseTreeRenderer renderer terms + pure . toS $ runParseTreeRenderer renderer (terms `using` parTraversable (parTuple2 r0 rdeepseq)) where go blob = do - terms <- parseBlob' blob - pure (blob, terms) + term <- parseBlob' blob + pure (blob, term) -- | Parse a SourceBlob. parseBlob' :: SourceBlob -> IO (Term (Syntax Text) (Record DefaultFields)) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 6ec2a3075..e2b383766 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -16,7 +16,6 @@ import qualified Data.ByteString as B import qualified Paths_semantic_diff as Library (version) import Source import Renderer --- import Renderer.SExpression import System.Directory import System.Environment import System.FilePath.Posix (takeFileName, (-<.>)) @@ -98,29 +97,29 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc <|> 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 ) + <*> ( 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 - <$> ( ( 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 - <$> some (argument str (metavar "FILES...")) - <|> ParseCommit - <$> option (eitherReader parseSha) (long "sha" <> metavar "SHA" <> help "Commit SHA") - <*> some (argument str (metavar "FILES...")) ) - <*> switch (long "debug") - <*> pure gitDir - <*> pure alternates ) + <$> ( ( 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 + <$> some (argument str (metavar "FILES...")) + <|> ParseCommit + <$> option (eitherReader parseSha) (long "sha" <> metavar "SHA" <> help "Commit SHA") + <*> some (argument str (metavar "FILES...")) ) + <*> switch (long "debug") + <*> pure gitDir + <*> pure alternates ) parseSha :: String -> Either String String parseSha s = case matchRegex regex s of diff --git a/test/Command/Spec.hs b/test/Command/Spec.hs deleted file mode 100644 index b97d4c1c5..000000000 --- a/test/Command/Spec.hs +++ /dev/null @@ -1,69 +0,0 @@ -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 - -spec :: Spec -spec = parallel $ do - describe "readFile" $ do - it "returns a blob for extant files" $ do - blob <- runCommand (readFile "semantic-diff.cabal") - fmap path blob `shouldBe` Just "semantic-diff.cabal" - - it "returns Nothing for absent files" $ do - blob <- runCommand (readFile "this file should not exist") - blob `shouldBe` Nothing - - describe "readFilesAtSHAs" $ do - it "returns blobs for the specified paths" $ do - blobs <- runCommand (readFilesAtSHAs repoPath [] ["methods.rb"] (shas methodsFixture)) - blobs `shouldBe` expectedBlobs methodsFixture - - it "returns blobs for all paths if none are specified" $ do - blobs <- runCommand (readFilesAtSHAs repoPath [] [] (shas methodsFixture)) - blobs `shouldBe` expectedBlobs methodsFixture - - it "returns entries for missing paths" $ do - blobs <- runCommand (readFilesAtSHAs repoPath [] ["this file should not exist"] (shas methodsFixture)) - blobs `shouldBe` [("this file should not exist", pure Nothing)] - - describe "parse" $ do - it "parses line by line if not given a language" $ do - term <- runCommand (parse Nothing methodsBlob) - fmap (const ()) term `shouldBe` cofree (() :< Indexed [ cofree (() :< Leaf "def foo\n"), cofree (() :< Leaf "end\n"), cofree (() :< Leaf "") ]) - - it "parses in the specified language" $ 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") - [ ("methods.rb", both Nothing (Just methodsBlob)) ] - methodsBlob = SourceBlob (Source "def foo\nend\n") "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) - -data Fixture = Fixture { shas :: Both String, expectedBlobs :: [(FilePath, Both (Maybe SourceBlob))] } diff --git a/test/Command/Diff/Spec.hs b/test/CommandSpec.hs similarity index 64% rename from test/Command/Diff/Spec.hs rename to test/CommandSpec.hs index 7bb599179..c0bfa19bd 100644 --- a/test/Command/Diff/Spec.hs +++ b/test/CommandSpec.hs @@ -1,24 +1,56 @@ -module Command.Diff.Spec where +module CommandSpec where import Command import Data.Aeson -import Data.Aeson.Types +import Data.Aeson.Types hiding (parse) import Data.Functor.Both -import Data.Map as Map +import Data.Map import Data.Maybe -import Data.Text.Lazy as T +import Data.String +import Info (DefaultFields) +import Language +import Prologue hiding (readFile, toList) import qualified Data.Vector as V import qualified Git.Types as Git -import Info -import Prelude -import Prologue (($), fmap, (.), pure, for, panic) import Renderer hiding (errors) import Source +import Syntax import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty spec :: Spec spec = parallel $ do + describe "readFile" $ do + it "returns a blob for extant files" $ do + blob <- runCommand (readFile "semantic-diff.cabal") + fmap path blob `shouldBe` Just "semantic-diff.cabal" + + it "returns Nothing for absent files" $ do + blob <- runCommand (readFile "this file should not exist") + blob `shouldBe` Nothing + + describe "readFilesAtSHAs" $ do + it "returns blobs for the specified paths" $ do + blobs <- runCommand (readFilesAtSHAs repoPath [] ["methods.rb"] (shas methodsFixture)) + blobs `shouldBe` expectedBlobs methodsFixture + + it "returns blobs for all paths if none are specified" $ do + blobs <- runCommand (readFilesAtSHAs repoPath [] [] (shas methodsFixture)) + blobs `shouldBe` expectedBlobs methodsFixture + + it "returns entries for missing paths" $ do + blobs <- runCommand (readFilesAtSHAs repoPath [] ["this file should not exist"] (shas methodsFixture)) + blobs `shouldBe` [("this file should not exist", pure Nothing)] + + describe "parse" $ do + it "parses line by line if not given a language" $ do + term <- runCommand (parse Nothing methodsBlob) + void term `shouldBe` cofree (() :< Indexed [ cofree (() :< Leaf "def foo\n"), cofree (() :< Leaf "end\n"), cofree (() :< Leaf "") ]) + + it "parses in the specified language" $ do + term <- runCommand (parse (Just Ruby) methodsBlob) + void term `shouldBe` cofree (() :< Indexed [ cofree (() :< Method [] (cofree (() :< Leaf "foo")) Nothing [] []) ]) + describe "fetchDiffs" $ do it "generates diff summaries for two shas" $ do (errors, summaries) <- fetchDiffsOutput summaryText "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" ["methods.rb"] Renderer.SummaryRenderer @@ -43,6 +75,14 @@ spec = parallel $ do fetchDiffsOutput summaryText "test/fixtures/git/examples/not-a-repo.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" ["methods.rb"] Renderer.SummaryRenderer `shouldThrow` errorCall "Could not open repository \"test/fixtures/git/examples/not-a-repo.git\"" + where repoPath = "test/fixtures/git/examples/all-languages.git" + methodsFixture = Fixture + (both "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe") + [ ("methods.rb", both Nothing (Just methodsBlob)) ] + methodsBlob = SourceBlob (Source "def foo\nend\n") "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) + +data Fixture = Fixture { shas :: Both String, expectedBlobs :: [(FilePath, Both (Maybe SourceBlob))] } + fetchDiffsOutput :: (Object -> Text) -> FilePath -> String -> String -> [FilePath] -> DiffRenderer DefaultFields Summaries -> IO (Maybe (Map Text Value), Maybe (Map Text [Text])) fetchDiffsOutput f gitDir sha1 sha2 filePaths renderer = do results <- fmap encode . runCommand $ do diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index 1f73a3e41..496a5b760 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -5,23 +5,42 @@ import Arguments import SemanticCmdLine import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty -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 + it "patchDiff" $ assertDiffOutput patchDiff patchOutput + it "splitDiff" $ assertDiffOutput splitDiff splitOutput + it "jsonDiff" $ assertDiffOutput jsonDiff jsonOutput + it "summaryDiff" $ assertDiffOutput summaryDiff summaryOutput + it "sExpressionDiff" $ assertDiffOutput sExpressionDiff sExpressionOutput + it "tocDiff" $ assertDiffOutput tocDiff tocOutput + describe "runParse" $ do - it "sExpression" $ do + it "sExpressionParseTree" $ assertParseOutput sExpressionParseTree sExpressionParseTreeOutput + it "jsonParseTree" $ assertParseOutput jsonParseTree jsonParseTreeOutput + it "jsonIndexParseTree" $ assertParseOutput jsonIndexParseTree jsonIndexParseTreeOutput + + where + assertDiffOutput format expected = do + let mode = DiffPaths "test/fixtures/ruby/method-declaration.A.rb" "test/fixtures/ruby/method-declaration.B.rb" + output <- runDiff $ format mode "" [] + when (output /= expected) $ print output -- Helpful for debugging + output `shouldBe` expected + + assertParseOutput format expected = 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` "" + output <- runParse $ format mode False "" [] + when (output /= expected) $ print output -- Helpful for debugging + output `shouldBe` expected + + patchOutput = "diff --git a/test/fixtures/ruby/method-declaration.A.rb b/test/fixtures/ruby/method-declaration.B.rb\nindex 0000000000000000000000000000000000000000..0000000000000000000000000000000000000000 100644\n--- a/test/fixtures/ruby/method-declaration.A.rb\n+++ b/test/fixtures/ruby/method-declaration.B.rb\n@@ -1,3 +1,4 @@\n-def foo\n+def bar(a)\n+ baz\n end\n\n" + splitOutput = "\n\n\n\n\n\n\n\n\n\n\n\n\n
1
    • def
    • foo
      • \n
1
    • def
    • bar
      • (
      • a
        • )\n
2
    • baz
      • \n
2
    • end
    • \n
3
    • end
    • \n
3
    		4
      \n" + summaryOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"replace\":[{\"start\":[1,5],\"end\":[1,8]},{\"start\":[1,5],\"end\":[1,8]}]},\"summary\":\"Replaced the 'foo' identifier with the 'bar' identifier in the 'bar(\226\128\166)' method\"},{\"span\":{\"insert\":{\"start\":[1,9],\"end\":[1,10]}},\"summary\":\"Added the 'a' identifier in the 'bar(\226\128\166)' method\"},{\"span\":{\"insert\":{\"start\":[2,3],\"end\":[2,6]}},\"summary\":\"Added the 'baz' identifier in the 'bar(\226\128\166)' method\"}]},\"errors\":{}}\n" + jsonOutput = "{\"oids\":[\"0000000000000000000000000000000000000000\",\"0000000000000000000000000000000000000000\"],\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"],\"rows\":[[{\"terms\":[{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[{\"category\":\"Identifier\",\"patch\":\"replace\",\"range\":[4,7]}],\"range\":[0,8]}],\"range\":[0,8]}],\"hasChanges\":true,\"range\":[0,8],\"number\":1},{\"terms\":[{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[{\"category\":\"Identifier\",\"patch\":\"replace\",\"range\":[4,7]},{\"category\":\"Params\",\"children\":[{\"category\":\"Identifier\",\"range\":[8,9]}],\"patch\":\"insert\",\"range\":[7,11]}],\"range\":[0,11]}],\"range\":[0,11]}],\"hasChanges\":true,\"range\":[0,11],\"number\":1}],[{\"terms\":[{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[{\"category\":\"Params\",\"children\":[],\"patch\":\"insert\",\"range\":[11,13]},{\"category\":\"Identifier\",\"patch\":\"insert\",\"range\":[13,16]}],\"range\":[11,17]}],\"range\":[11,17]}],\"hasChanges\":true,\"range\":[11,17],\"number\":2}],[{\"terms\":[{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[],\"range\":[8,11]}],\"range\":[8,12]}],\"hasChanges\":false,\"range\":[8,12],\"number\":2},{\"terms\":[{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[],\"range\":[17,20]}],\"range\":[17,21]}],\"hasChanges\":false,\"range\":[17,21],\"number\":3}],[{\"terms\":[{\"category\":\"Program\",\"children\":[],\"range\":[12,12]}],\"hasChanges\":false,\"range\":[12,12],\"number\":3},{\"terms\":[{\"category\":\"Program\",\"children\":[],\"range\":[21,21]}],\"hasChanges\":false,\"range\":[21,21],\"number\":4}]]}\n" + sExpressionOutput = "(Program\n (Method\n { (Identifier)\n ->(Identifier) }\n {+(Params\n (Identifier))+}\n {+(Identifier)+}))" + tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n" + + sExpressionParseTreeOutput = "(Program\n (Binary\n (Identifier)\n (Other \"and\")\n (Identifier)))" + jsonParseTreeOutput = "[{\"filePath\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Other \\\"and\\\"\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}}},[]]\n" + jsonIndexParseTreeOutput = "[{\"programNodes\":[{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},{\"category\":\"Binary\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}},{\"category\":\"Identifier\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Other \\\"and\\\"\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"filePath\":\"test/fixtures/ruby/and-or.A.rb\"},[]]\n" diff --git a/test/Spec.hs b/test/Spec.hs index d57033d67..98523d4c9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,8 +2,7 @@ module Main where import Prologue import qualified AlignmentSpec -import qualified Command.Spec -import qualified Command.Diff.Spec +import qualified CommandSpec import qualified Data.Mergeable.Spec import qualified Data.RandomWalkSimilarity.Spec import qualified Data.Syntax.Assignment.Spec @@ -25,8 +24,7 @@ main :: IO () main = hspec $ do parallel $ do describe "Alignment" AlignmentSpec.spec - describe "Command" Command.Spec.spec - describe "Command.Diff" Command.Diff.Spec.spec + describe "Command" CommandSpec.spec describe "Data.Mergeable" Data.Mergeable.Spec.spec describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec describe "Data.Syntax.Assignment" Data.Syntax.Assignment.Spec.spec diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index ffeaf7d68..0541ee458 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -55,8 +55,9 @@ diffFilePaths paths = do parseFilePath :: FilePath -> IO ByteString parseFilePath path = do source <- readFileToUnicode path - term <- parseBlob' $ sourceBlob source path - pure $ printTerm term 0 TreeOnly + let blob = sourceBlob source path + term <- parseBlob' blob + pure $ sExpressionParseTree TreeOnly blob term -- | Read a file to a SourceBlob readFileToSourceBlob :: FilePath -> IO (Maybe SourceBlob)