diff --git a/.atom-build.yml b/.atom-build.yml deleted file mode 100644 index 741285538..000000000 --- a/.atom-build.yml +++ /dev/null @@ -1,11 +0,0 @@ -# Build configuration for https://atom.io/packages/build -cmd: stack build -name: semantic-diff -env: - PATH: ~/.local/bin:~/Developer/Tools:~/Library/Haskell/bin:/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin -targets: - test: - cmd: stack build semantic-diff:test - keymap: cmd-u -errorMatch: -- \n(?/[^:]+):(?\d+):((?\d+):)? diff --git a/app/Main.hs b/app/Main.hs index f913510b8..b9c831403 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,3 @@ module Main (main) where -import SemanticDiff (main) +import Semantic (main) diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 index ae5260f29..000000000 --- a/bench/Main.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveAnyClass, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Arguments -import Criterion.Main -import Data.Function -import Data.List (genericLength) -import Data.String -import Patch -import Prologue -import qualified Renderer as R -import SemanticDiff (fetchDiffs) -import qualified SemanticDiffPar -import SES -import System.Directory (makeAbsolute) - -main :: IO () -main = defaultMain - [ bgroup "ses" - [ bench "0,0" (nf (uncurry benchmarkSES) ([], [])) - , bench "1,1, =" (nf (uncurry benchmarkSES) ([lower], [lower])) - , bench "1,1, ≠" (nf (uncurry benchmarkSES) ([lower], [upper])) - , bench "10,10, =" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 lower)) - , bench "10,10, ≠" (nf (uncurry benchmarkSES) (replicate 10 lower, replicate 10 upper)) - , bench "100,100, =" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 lower)) - , bench "100,100, ≠" (nf (uncurry benchmarkSES) (replicate 100 lower, replicate 100 upper)) - ] - , syncAsyncBenchmark - ] - where lower = ['a'..'z'] - upper = ['A'..'Z'] - -benchmarkSES :: [String] -> [String] -> [Either String (Patch String)] -benchmarkSES = ses compare cost - where compare a b = if a == b then Just (Left a) else Nothing - cost = either (const 0) (sum . fmap genericLength) - -instance NFData a => NFData (Patch a) - -syncAsyncBenchmark :: Benchmark -syncAsyncBenchmark = - bgroup "async vs par" [ - bench "async" . whnfIO $ SemanticDiff.fetchDiffs =<< theArgs, - bench "par" . whnfIO $ SemanticDiffPar.fetchDiffs =<< theArgs - ] - -theArgs :: IO Arguments -theArgs = do - jqueryPath <- makeAbsolute "test/repos/jquery" - pure $ args jqueryPath sha1 sha2 files R.Patch - where - sha1 = "70526981916945dc4093e116a3de61b1777d4718" - sha2 = "e5ffcb0838c894e26f4ff32dfec162cf624d8d7d" - files = [ - "src/manipulation/getAll.js", - "src/manipulation/support.js", - "src/manipulation/wrapMap.js", - "src/offset.js", - "test/unit/css.js", - "test/unit/deferred.js", - "test/unit/deprecated.js", - "test/unit/effects.js", - "test/unit/event.js", - "test/unit/offset.js", - "test/unit/wrap.js" - ] diff --git a/bench/SemanticDiffPar.hs b/bench/SemanticDiffPar.hs deleted file mode 100644 index cfa440087..000000000 --- a/bench/SemanticDiffPar.hs +++ /dev/null @@ -1,12 +0,0 @@ -module SemanticDiffPar where - -import Arguments -import qualified Control.Monad.Par.IO as ParIO -import Control.Monad.Reader -import qualified Data.Text as T -import Prologue -import qualified Renderer as R -import SemanticDiff - -fetchDiffs :: Arguments -> IO [T.Text] -fetchDiffs args@Arguments{..} = pure . pure . R.concatOutputs =<< (ParIO.runParIO . liftIO $ for filePaths (fetchDiff args)) diff --git a/script/generate-example b/script/generate-example index 3c151dcbf..b56a64884 100755 --- a/script/generate-example +++ b/script/generate-example @@ -40,28 +40,28 @@ generate_example () { diffFileBA="${fileB%%.*}.diffB-A.txt" status $parseFileA - stack exec semantic-diff -- --sexpression --parse $fileA > $parseFileA + stack exec semantic parse -- --sexpression $fileA > $parseFileA status $parseFileB - stack exec semantic-diff -- --sexpression --parse $fileB > $parseFileB + stack exec semantic parse -- --sexpression $fileB > $parseFileB status $diffFileAddA - stack exec semantic-diff -- --sexpression --no-index /dev/null $fileA > $diffFileAddA + stack exec semantic diff -- --sexpression /dev/null $fileA > $diffFileAddA status $diffFileRemoveA - stack exec semantic-diff -- --sexpression --no-index $fileA /dev/null > $diffFileRemoveA + stack exec semantic diff -- --sexpression $fileA /dev/null > $diffFileRemoveA status $diffFileAddB - stack exec semantic-diff -- --sexpression --no-index /dev/null $fileB > $diffFileAddB + stack exec semantic diff -- --sexpression --no-index /dev/null $fileB > $diffFileAddB status $diffFileRemoveB - stack exec semantic-diff -- --sexpression --no-index $fileB /dev/null > $diffFileRemoveB + stack exec semantic diff -- --sexpression $fileB /dev/null > $diffFileRemoveB status $diffFileAB - stack exec semantic-diff -- --sexpression --no-index $fileA $fileB > $diffFileAB + stack exec semantic diff -- --sexpression $fileA $fileB > $diffFileAB status $diffFileBA - stack exec semantic-diff -- --sexpression --no-index $fileB $fileA > $diffFileBA + stack exec semantic diff -- --sexpression $fileB $fileA > $diffFileBA } if [[ -d $1 ]]; then diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 081111d3f..04d8ee5a9 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -1,5 +1,5 @@ name: semantic-diff -version: 0.2.0 +version: 0.3.0 synopsis: Initial project template from stack description: Please see README.md homepage: http://github.com/github/semantic-diff#readme @@ -63,7 +63,7 @@ library , Renderer.Summary , Renderer.SExpression , Renderer.TOC - , SemanticDiff + , Semantic , SES , SES.Myers , Source @@ -130,7 +130,7 @@ library ghc-options: -Wall -fno-warn-name-shadowing -O2 -j ghc-prof-options: -fprof-auto -executable semantic-diff +executable semantic hs-source-dirs: app main-is: Main.hs ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O2 -pgml=script/g++ @@ -141,23 +141,6 @@ executable semantic-diff default-language: Haskell2010 default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards -benchmark semantic-diff-bench - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: bench - other-modules: SemanticDiffPar - build-depends: base - , criterion - , directory - , leancheck - , monad-par - , mtl - , semantic-diff - , text >= 1.2.1.3 - ghc-options: -threaded -rtsopts -with-rtsopts=-N -j -O2 -static -pgml=script/g++ - default-language: Haskell2010 - default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards - test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test @@ -170,6 +153,7 @@ test-suite test , Data.RandomWalkSimilarity.Spec , Data.Syntax.Assignment.Spec , DiffSpec + , SemanticSpec , SummarySpec , GitmonClientSpec , InterpreterSpec diff --git a/src/Arguments.hs b/src/Arguments.hs index 6124b88fe..26d35cc2e 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -1,153 +1,37 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -module Arguments (Arguments(..), CmdLineOptions(..), DiffMode(..), ExtraArg(..), RunMode(..), programArguments, args, diffPathsArgs, parseArgs) where +module Arguments where -import Data.Functor.Both +import Command import Data.Maybe -import Data.List.Split -import Prologue hiding ((<>)) import Prelude -import System.Environment -import System.Directory -import System.FilePath.Posix (takeFileName, (-<.>)) -import System.IO.Error (IOError) -import qualified Renderer as R -data ExtraArg = ShaPair (Both (Maybe String)) - | FileArg FilePath - deriving (Show) +data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath + deriving Show -data DiffMode = PathDiff (Both FilePath) - | CommitDiff - deriving (Show) - -data RunMode = Diff - | Parse - deriving (Show) - --- | The command line options to the application (arguments for optparse-applicative). -data CmdLineOptions = CmdLineOptions - { outputFormat :: R.Format - , maybeTimeout :: Maybe Float - , outputFilePath :: Maybe FilePath - , commitSha' :: Maybe String - , noIndex :: Bool - , extraArgs :: [ExtraArg] - , debug' :: Bool - , runMode' :: RunMode - } - --- | Arguments for the program (includes command line, environment, and defaults). -data Arguments = Arguments - { gitDir :: FilePath - , alternateObjectDirs :: [FilePath] - , format :: R.Format - , timeoutInMicroseconds :: Int - , outputPath :: Maybe FilePath - , commitSha :: Maybe String +data DiffArguments = DiffArguments + { encodeDiff :: DiffEncoder , diffMode :: DiffMode - , runMode :: RunMode - , shaRange :: Both (Maybe String) - , filePaths :: [FilePath] + , gitDir :: FilePath + , alternateObjectDirs :: [FilePath] + } deriving Show + +data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath] + deriving Show + +data ParseArguments = ParseArguments + { renderParseTree :: ParseTreeRenderer + , parseMode :: ParseMode , debug :: Bool - } deriving (Show) + , gitDir :: FilePath + , alternateObjectDirs :: [FilePath] + } deriving Show --- | Returns Arguments for the program from parsed command line arguments. -programArguments :: CmdLineOptions -> IO Arguments -programArguments CmdLineOptions{..} = do - pwd <- getCurrentDirectory - gitDir <- fromMaybe pwd <$> lookupEnv "GIT_DIR" - eitherObjectDirs <- try $ parseObjectDirs . toS <$> getEnv "GIT_ALTERNATE_OBJECT_DIRECTORIES" - outputPath <- getOutputPath outputFilePath - let alternateObjectDirs = case (eitherObjectDirs :: Either IOError [FilePath]) of - (Left _) -> [] - (Right objectDirs) -> objectDirs +data ProgramMode = Parse ParseArguments | Diff DiffArguments + deriving Show - let filePaths = fetchPaths extraArgs - pure Arguments - { gitDir = gitDir - , alternateObjectDirs = alternateObjectDirs - , format = outputFormat - , timeoutInMicroseconds = maybe defaultTimeout toMicroseconds maybeTimeout - , outputPath = outputPath - , commitSha = commitSha' - , diffMode = case (noIndex, filePaths) of - (True, [fileA, fileB]) -> PathDiff (both fileA fileB) - (_, _) -> CommitDiff - , runMode = runMode' - , shaRange = fetchShas extraArgs - , filePaths = filePaths - , debug = debug' - } - where - fetchPaths :: [ExtraArg] -> [FilePath] - fetchPaths [] = [] - fetchPaths (FileArg x:xs) = x : fetchPaths xs - fetchPaths (_:xs) = fetchPaths xs - - fetchShas :: [ExtraArg] -> Both (Maybe String) - fetchShas [] = both Nothing Nothing - fetchShas (ShaPair x:_) = x - fetchShas (_:xs) = fetchShas xs - - getOutputPath Nothing = pure Nothing - getOutputPath (Just path) = do - isDir <- doesDirectoryExist path - pure . Just $ if isDir then takeFileName path -<.> ".html" else path - - --- | Quickly assemble an Arguments data record with defaults. -args :: FilePath -> String -> String -> [String] -> R.Format -> Arguments -args gitDir sha1 sha2 filePaths format = Arguments - { gitDir = gitDir - , alternateObjectDirs = [] - , format = format - , timeoutInMicroseconds = defaultTimeout - , outputPath = Nothing - , commitSha = Nothing - , diffMode = CommitDiff - , runMode = Diff - , shaRange = Just <$> both sha1 sha2 - , filePaths = filePaths - , debug = False - } - -diffPathsArgs :: FilePath -> Both FilePath -> R.Format -> Arguments -diffPathsArgs gitDir paths format = Arguments - { gitDir = gitDir - , alternateObjectDirs = [] - , format = format - , timeoutInMicroseconds = defaultTimeout - , outputPath = Nothing - , commitSha = Nothing - , diffMode = PathDiff paths - , runMode = Diff - , shaRange = both Nothing Nothing - , filePaths = [] - , debug = False - } - -parseArgs :: [String] -> R.Format -> Arguments -parseArgs filePaths format = Arguments - { gitDir = "" - , alternateObjectDirs = [] - , format = format - , timeoutInMicroseconds = defaultTimeout - , outputPath = Nothing - , commitSha = Nothing - , diffMode = CommitDiff - , runMode = Parse - , shaRange = both Nothing Nothing - , filePaths = filePaths - , debug = False - } - --- | 7 seconds -defaultTimeout :: Int -defaultTimeout = 7 * 1000000 - -toMicroseconds :: Float -> Int -toMicroseconds num = floor $ num * 1000000 - -parseObjectDirs :: FilePath -> [FilePath] -parseObjectDirs = splitWhen (== ':') +data Arguments = Arguments + { programMode :: ProgramMode + , outputFilePath :: Maybe FilePath + } deriving Show diff --git a/src/Command.hs b/src/Command.hs index 6f2b2d880..7223040f0 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds, GADTs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Command ( Command -- Constructors @@ -10,6 +11,14 @@ module Command , maybeDiff , renderDiffs , concurrently +, patchDiff +, splitDiff +, jsonDiff +, summaryDiff +, sExpressionDiff +, tocDiff +, DiffEncoder +, ParseTreeRenderer -- Evaluation , runCommand ) where @@ -20,15 +29,16 @@ 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 import Data.String import Diff -import Info -import Interpreter import GHC.Conc (numCapabilities) import qualified Git import Git.Blob @@ -37,14 +47,19 @@ import Git.Libgit2.Backend import Git.Repository import Git.Types import GitmonClient +import Info +import Interpreter import Language import Patch import Prologue hiding (concurrently, Concurrently, readFile) +import qualified Renderer as R +import qualified Renderer.SExpression as R import Renderer import Source import Syntax import System.FilePath import Term +import Text.Show -- | High-level commands encapsulating the work done to perform a diff or parse operation. @@ -188,5 +203,69 @@ runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBl runRenderDiffs = runDiffRenderer +type ParseTreeRenderer = Bool -> [SourceBlob] -> IO 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 ParseTreeRenderer where + showsPrec d _ = showParen (d >= 10) $ showString "ParseTreeRenderer " + +instance Listable ParseTreeRenderer 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 patchDiff + \/ cons0 splitDiff + \/ cons0 jsonDiff + \/ cons0 summaryDiff + \/ cons0 sExpressionDiff + \/ cons0 tocDiff + instance MonadIO Command where liftIO io = LiftIO io `Then` return + +instance Show1 CommandF where + liftShowsPrec sp sl d command = case command of + ReadFile path -> showsUnaryWith showsPrec "ReadFile" d path + ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas + where showsQuaternaryWith sp1 sp2 sp3 sp4 name d x y z w = showParen (d > 10) $ + showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y . showChar ' ' . sp3 11 z . showChar ' ' . sp4 11 w + Parse language _ -> showsBinaryWith showsPrec (const showChar) "Parse" d language '_' + Diff _ -> showsUnaryWith (const showChar) "Diff" d '_' + RenderDiffs renderer _ -> showsBinaryWith showsPrec (const showChar) "RenderDiffs" d renderer '_' + Concurrently commands f -> showsBinaryWith (liftShowsPrec sp sl) (const showChar) "Concurrently" d (traverse f commands) '_' + LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_' diff --git a/src/Command/Parse.hs b/src/Command/Parse.hs index 7da316a28..f21965bad 100644 --- a/src/Command/Parse.hs +++ b/src/Command/Parse.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Command.Parse where -import Arguments import Category import Data.Aeson (ToJSON, toJSON, encode, object, (.=)) import Data.Aeson.Types (Pair) @@ -65,19 +64,17 @@ parseNodeToJSONFields ParseNode{..} = <> [ "identifier" .= identifier | isJust identifier ] -- | Parses file contents into an SExpression format for the provided arguments. -parseSExpression :: Arguments -> IO ByteString -parseSExpression = - pure . printTerms TreeOnly <=< parse <=< sourceBlobsFromArgs +sExpressionParseTree :: Bool -> [SourceBlob] -> IO ByteString +sExpressionParseTree _ blobs = + pure . printTerms TreeOnly =<< parse blobs where parse = traverse (\sourceBlob@SourceBlob{..} -> parserForType (toS (takeExtension path)) sourceBlob) type RAlgebra t a = Base t (t, a) -> a -parseRoot :: (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> Arguments -> IO [root] -parseRoot construct combine args@Arguments{..} = do - blobs <- sourceBlobsFromArgs args - for blobs (\ sourceBlob@SourceBlob{..} -> do - parsedTerm <- parseWithDecorator (decorator source) path sourceBlob - pure $! construct path (para algebra parsedTerm)) +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 @@ -85,12 +82,12 @@ parseRoot construct combine args@Arguments{..} = do ParseNode (toS category) range head sourceSpan (identifierFor syntax) -- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON. -parseIndex :: Arguments -> IO ByteString -parseIndex = fmap (toS . encode) . parseRoot IndexFile (\ node siblings -> node : concat siblings) +jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString +jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : concat siblings) -- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON. -parseTree :: Arguments -> IO ByteString -parseTree = fmap (toS . encode) . parseRoot ParseTreeFile Rose +jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString +jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose -- | Determines the term decorator to use when parsing. parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText)) @@ -138,13 +135,6 @@ sourceBlobsFromSha commitSha gitDir filePaths = do 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 --- | For the file paths and commit sha provided, extract only the BlobEntries and represent them as SourceBlobs. -sourceBlobsFromArgs :: Arguments -> IO [SourceBlob] -sourceBlobsFromArgs Arguments{..} = - case commitSha of - Just commitSha' -> sourceBlobsFromSha commitSha' gitDir filePaths - _ -> sourceBlobsFromPaths filePaths - -- | 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 <$> parserForType (toS (takeExtension path)) blob diff --git a/src/Renderer.hs b/src/Renderer.hs index 70b0450b2..b95fdebb4 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -2,15 +2,15 @@ module Renderer ( DiffRenderer(..) , runDiffRenderer -, Format(..) , Summaries(..) , File(..) ) where import Data.Aeson (ToJSON, Value) import Data.Functor.Both +import Data.Functor.Classes +import Text.Show import Data.Map as Map hiding (null) -import Data.Functor.Listable import Data.Record import Diff import Info @@ -41,21 +41,17 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of SExpressionDiffRenderer format -> R.sExpression format ToCRenderer -> R.toc --- | The available types of diff rendering. -data Format = Split | Patch | JSON | Summary | SExpression | TOC | Index | ParseTree - deriving (Show) - newtype File = File { unFile :: Text } deriving Show +instance Show (DiffRenderer fields output) where + showsPrec _ SplitRenderer = showString "SplitRenderer" + showsPrec _ PatchRenderer = showString "PatchRenderer" + showsPrec _ JSONDiffRenderer = showString "JSONDiffRenderer" + showsPrec _ SummaryRenderer = showString "SummaryRenderer" + showsPrec d (SExpressionDiffRenderer format) = showsUnaryWith showsPrec "SExpressionDiffRenderer" d format + showsPrec _ ToCRenderer = showString "ToCRenderer" + instance Monoid File where mempty = File mempty mappend (File a) (File b) = File (a <> "\n" <> b) - -instance Listable Format where - tiers = cons0 Split - \/ cons0 Patch - \/ cons0 JSON - \/ cons0 Summary - \/ cons0 SExpression - \/ cons0 TOC diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index b4c7b78ce..f4057531d 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -15,6 +15,7 @@ import Syntax import Term data SExpressionFormat = TreeOnly | TreeAndRanges + deriving (Show) sExpression :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> Both SourceBlob -> Diff (Syntax Text) (Record fields) -> ByteString sExpression format _ diff = printDiff diff 0 format diff --git a/src/Semantic.hs b/src/Semantic.hs new file mode 100644 index 000000000..ccbd8a87b --- /dev/null +++ b/src/Semantic.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} +module Semantic (main, runDiff, runParse) where + +import Arguments +import Command +import Command.Parse +import Data.Functor.Both +import Data.List.Split (splitWhen) +import Data.String +import Data.Version (showVersion) +import Development.GitRev +import Options.Applicative hiding (action) +import Prologue hiding (concurrently, fst, snd, readFile) +import qualified Data.ByteString as B +import qualified Paths_semantic_diff as Library (version) +import Source +import System.Directory +import System.Environment +import System.FilePath.Posix (takeFileName, (-<.>)) +import System.IO.Error (IOError) +import Text.Regex + +main :: IO () +main = do + gitDir <- findGitDir + alternates <- findAlternates + Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates) + outputPath <- getOutputPath outputFilePath + text <- case programMode of + Diff args -> runDiff args + Parse args -> runParse args + writeToOutput outputPath text + + where + findGitDir = do + pwd <- getCurrentDirectory + fromMaybe pwd <$> lookupEnv "GIT_DIR" + + findAlternates = do + eitherObjectDirs <- try $ splitWhen (== ':') . toS <$> getEnv "GIT_ALTERNATE_OBJECT_DIRECTORIES" + pure $ case (eitherObjectDirs :: Either IOError [FilePath]) of + (Left _) -> [] + (Right objectDirs) -> objectDirs + + getOutputPath Nothing = pure Nothing + getOutputPath (Just path) = do + isDir <- doesDirectoryExist path + pure . Just $ if isDir then takeFileName path -<.> ".html" else path + + writeToOutput :: Maybe FilePath -> ByteString -> IO () + writeToOutput = maybe B.putStr B.writeFile + +runDiff :: DiffArguments -> IO ByteString +runDiff DiffArguments{..} = runCommand $ do + diffs <- case diffMode of + DiffPaths pathA pathB -> do + let paths = both pathA pathB + blobs <- traverse readFile paths + terms <- traverse (traverse parseBlob) blobs + diff' <- maybeDiff terms + pure [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')] + DiffCommits sha1 sha2 paths -> do + blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2) + concurrently blobPairs . uncurry $ \ path blobs -> do + terms <- concurrently blobs (traverse parseBlob) + diff' <- maybeDiff terms + pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff') + encodeDiff (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 + renderParseTree debug blobs + +-- | A parser for the application's command-line arguments. +arguments :: FilePath -> [FilePath] -> ParserInfo Arguments +arguments gitDir alternates = info (version <*> helper <*> argumentsParser) description + where + version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") + versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" + description = fullDesc <> progDesc "Set the GIT_DIR environment variable to specify a different git repository. Set GIT_ALTERNATE_OBJECT_DIRECTORIES to specify location of alternates." + <> header "semantic -- Parse and diff semantically" + + argumentsParser = Arguments + <$> hsubparser (diffCommand <> parseCommand) + <*> optional (strOption (long "output" <> short 'o' <> help "Output path (directory for split diffs), defaults to stdout")) + + 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 ) + + parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths")) + parseArgumentsParser = Parse + <$> ( ParseArguments + <$> ( 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 + Just [sha] -> Right sha + _ -> Left $ s <> " is not a valid SHA-1" + where regex = mkRegexWithOpts "([0-9a-f]{40})" True False diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs deleted file mode 100644 index 5b01dd1f9..000000000 --- a/src/SemanticDiff.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module SemanticDiff (main) where - -import Arguments -import Command -import Command.Parse -import Development.GitRev -import Data.Aeson -import qualified Data.ByteString as B -import Data.Functor.Both -import Data.String -import Data.Version (showVersion) -import Options.Applicative hiding (action) -import qualified Paths_semantic_diff as Library (version) -import Prologue hiding (concurrently, fst, snd, readFile) -import qualified Renderer as R -import qualified Renderer.SExpression as R -import Source -import Text.Regex - -main :: IO () -main = do - args@Arguments{..} <- programArguments =<< execParser argumentsParser - text <- case runMode of - Diff -> runCommand $ do - let render = case format of - R.Split -> fmap encodeText . renderDiffs R.SplitRenderer - R.Patch -> fmap encodeText . renderDiffs R.PatchRenderer - R.JSON -> fmap encodeJSON . renderDiffs R.JSONDiffRenderer - R.Summary -> fmap encodeSummaries . renderDiffs R.SummaryRenderer - R.SExpression -> renderDiffs (R.SExpressionDiffRenderer R.TreeOnly) - R.TOC -> fmap encodeSummaries . renderDiffs R.ToCRenderer - _ -> fmap encodeText . renderDiffs R.PatchRenderer - diffs <- case diffMode of - PathDiff paths -> do - blobs <- traverse readFile paths - terms <- traverse (traverse parseBlob) blobs - diff' <- maybeDiff terms - return [(fromMaybe . emptySourceBlob <$> paths <*> blobs, diff')] - CommitDiff -> do - blobPairs <- readFilesAtSHAs gitDir alternateObjectDirs filePaths (fromMaybe (toS nullOid) <$> shaRange) - concurrently blobPairs . uncurry $ \ path blobs -> do - terms <- concurrently blobs (traverse parseBlob) - diff' <- maybeDiff terms - return (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff') - render (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff) - Parse -> case format of - R.Index -> parseIndex args - R.SExpression -> parseSExpression args - _ -> parseTree args - writeToOutput outputPath text - where encodeText = encodeUtf8 . R.unFile - encodeJSON = toS . (<> "\n") . encode - encodeSummaries = toS . (<> "\n") . encode - --- | A parser for the application's command-line arguments. -argumentsParser :: ParserInfo CmdLineOptions -argumentsParser = info (version <*> helper <*> argumentsP) - (fullDesc <> progDesc "Set the GIT_DIR environment variable to specify the git repository. Set GIT_ALTERNATE_OBJECT_DIRECTORIES to specify location of alternates." - <> header "semantic-diff - Show semantic changes between commits") - where - argumentsP :: Parser CmdLineOptions - argumentsP = CmdLineOptions - <$> (flag R.Split R.Patch (long "patch" <> help "output a patch(1)-compatible diff") - <|> flag R.Split R.JSON (long "json" <> help "output a json diff") - <|> flag' R.Split (long "split" <> help "output a split diff") - <|> flag' R.Summary (long "summary" <> help "output a diff summary") - <|> flag' R.SExpression (long "sexpression" <> help "output an s-expression diff tree") - <|> flag' R.TOC (long "toc" <> help "output a table of contents diff summary") - <|> flag' R.Index (long "index" <> help "output indexable JSON parse output") - <|> flag' R.ParseTree (long "parse-tree" <> help "output JSON parse tree structure")) - <*> optional (option auto (long "timeout" <> help "timeout for per-file diffs in seconds, defaults to 7 seconds")) - <*> optional (strOption (long "output" <> short 'o' <> help "output directory for split diffs, defaults to stdout if unspecified")) - <*> optional (strOption (long "commit" <> short 'c' <> help "single commit entry for parsing")) - <*> switch (long "no-index" <> help "compare two paths on the filesystem") - <*> some (argument (eitherReader parseShasAndFiles) (metavar "SHA_A..SHAB FILES...")) - <*> switch (long "debug" <> short 'd' <> help "set debug mode for parsing which outputs sourcetext for each syntax node") - <*> flag Diff Parse (long "parse" <> short 'p' <> help "parses a source file without diffing") - where - parseShasAndFiles :: String -> Either String ExtraArg - parseShasAndFiles s = case matchRegex regex s of - Just ["", sha2] -> Right . ShaPair $ both Nothing (Just sha2) - Just [sha1, sha2] -> Right . ShaPair $ Just <$> both sha1 sha2 - _ -> Right $ FileArg s - where regex = mkRegexWithOpts "([0-9a-f]{40})\\.\\.([0-9a-f]{40})" True False - -versionString :: String -versionString = "semantic-diff version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" - -version :: Parser (a -> a) -version = infoOption versionString (long "version" <> short 'V' <> help "output the version of the program") - -writeToOutput :: Maybe FilePath -> ByteString -> IO () -writeToOutput = maybe B.putStr B.writeFile diff --git a/test/Command/Parse/Spec.hs b/test/Command/Parse/Spec.hs index 23006a6f2..6070d95ae 100644 --- a/test/Command/Parse/Spec.hs +++ b/test/Command/Parse/Spec.hs @@ -1,34 +1,20 @@ module Command.Parse.Spec where import Command.Parse -import Data.Functor.Listable +import Control.Monad import Prelude import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty -import Test.Hspec.LeanCheck -import Test.LeanCheck -import Arguments -import Renderer spec :: Spec -spec = parallel $ - context "parse" $ - prop "all valid formats should produce output" . forAll (isParseFormat `filterT` tiers) $ - \format -> - case format of - SExpression -> do - output <- parseSExpression $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format - output `shouldNotBe` "" - Index -> do - output <- parseIndex $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format - output `shouldNotBe` "" - _ -> do - output <- parseTree $ parseArgs ["test/fixtures/ruby/and-or.A.rb"] format - output `shouldNotBe` "" - -isParseFormat :: Format -> Bool -isParseFormat a | Index <- a = True - | ParseTree <- a = True - | JSON <- a = True - | SExpression <- a = True - | otherwise = False +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` "" diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs new file mode 100644 index 000000000..ea1b744c4 --- /dev/null +++ b/test/SemanticSpec.hs @@ -0,0 +1,23 @@ +module SemanticSpec where + +import Prologue +import Arguments +import Semantic +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 "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` "" diff --git a/test/Spec.hs b/test/Spec.hs index 5fcd715ff..25b1c0b4c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,6 +19,7 @@ import qualified SourceSpec import qualified TermSpec import qualified TOCSpec import qualified IntegrationSpec +import qualified SemanticSpec import Test.Hspec main :: IO () @@ -39,6 +40,7 @@ main = hspec $ do describe "SES.Myers" SES.Myers.Spec.spec describe "Source" SourceSpec.spec describe "Term" TermSpec.spec + describe "Semantic" SemanticSpec.spec describe "TOC" TOCSpec.spec describe "Integration" IntegrationSpec.spec