diff --git a/.gitignore b/.gitignore index 3f60e903d..94cc31009 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,6 @@ vendor/icu/common/ vendor/icu/bin/ vendor/icu/Makefile bin/ + +*.hp +*.prof diff --git a/.gitmodules b/.gitmodules index 8408b932a..410930286 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,9 +1,3 @@ -[submodule "vendor/text-icu"] - path = vendor/text-icu - url = https://github.com/joshvera/text-icu -[submodule "vendor/gitlib"] - path = vendor/gitlib - url = https://github.com/joshvera/gitlib [submodule "test/repos/jquery"] path = test/repos/jquery url = https://github.com/jquery/jquery diff --git a/HLint.hs b/HLint.hs index 24c631b6e..f6fdb6372 100644 --- a/HLint.hs +++ b/HLint.hs @@ -3,6 +3,7 @@ import "hint" HLint.Dollar import "hint" HLint.Generalise ignore "Use mappend" +ignore "Redundant do" error "generalize ++" = (++) ==> (<>) -- AMP fallout error "generalize mapM" = mapM ==> traverse diff --git a/languages/c/c.cabal b/languages/c/c.cabal index cda8b6b69..ed02cdbf0 100644 --- a/languages/c/c.cabal +++ b/languages/c/c.cabal @@ -17,6 +17,7 @@ library build-depends: base >= 4.7 && < 5 , haskell-tree-sitter default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-c/src/parser.c source-repository head diff --git a/languages/go/go.cabal b/languages/go/go.cabal index f600acfdc..7ccba0bc1 100644 --- a/languages/go/go.cabal +++ b/languages/go/go.cabal @@ -17,6 +17,7 @@ library build-depends: base >= 4.7 && < 5 , haskell-tree-sitter default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-go/src/parser.c source-repository head diff --git a/languages/python/python.cabal b/languages/python/python.cabal index 345cea22f..6a6dc08b1 100644 --- a/languages/python/python.cabal +++ b/languages/python/python.cabal @@ -17,6 +17,7 @@ library build-depends: base >= 4.7 && < 5 , haskell-tree-sitter default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-python/src/parser.c , vendor/tree-sitter-python/src/scanner.cc extra-libraries: stdc++ diff --git a/languages/ruby/ruby.cabal b/languages/ruby/ruby.cabal index 5f99d16f1..dc0524572 100644 --- a/languages/ruby/ruby.cabal +++ b/languages/ruby/ruby.cabal @@ -17,6 +17,7 @@ library build-depends: base >= 4.7 && < 5 , haskell-tree-sitter default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-ruby/src/parser.c , vendor/tree-sitter-ruby/src/scanner.cc extra-libraries: stdc++ diff --git a/languages/typescript/typescript.cabal b/languages/typescript/typescript.cabal index 27424dba1..c28eff377 100644 --- a/languages/typescript/typescript.cabal +++ b/languages/typescript/typescript.cabal @@ -17,6 +17,7 @@ library build-depends: base >= 4.7 && < 5 , haskell-tree-sitter default-language: Haskell2010 + default-extensions: FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards c-sources: vendor/tree-sitter-typescript/src/parser.c , vendor/tree-sitter-typescript/src/scanner.c cc-options: -std=c99 -Os diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 3c2b97abc..ac2653338 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -19,7 +19,6 @@ library , Category , Command , Command.Files - , Command.Git , Data.Align.Generic , Data.Functor.Both , Data.Functor.Classes.Eq.Generic @@ -81,13 +80,10 @@ library , FDoc.Term , FDoc.RecursionSchemes , FDoc.NatExample - , GitmonClient build-depends: base >= 4.8 && < 5 , aeson - , aeson-pretty , ansi-terminal , array - , async-pool , async , bifunctors , bytestring @@ -95,13 +91,10 @@ library , comonad , containers , directory - , dlist , effects , filepath , free , freer-cofreer - , gitlib - , gitlib-libgit2 , gitrev , hashable , kdt @@ -111,37 +104,28 @@ library , mtl , optparse-applicative , parallel - , pointed , protolude , recursion-schemes - , regex-compat , semigroups , split , template-haskell , text >= 1.2.1.3 - , text-icu , these , haskell-tree-sitter - , vector - , wl-pprint-text , c , go , ruby , typescript , python - , network - , clock - , yaml - , unordered-containers default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, StrictData - ghc-options: -Wall -fno-warn-name-shadowing -O2 -j - ghc-prof-options: -fprof-auto + ghc-options: -Wall -fno-warn-name-shadowing -O -j + ghc-prof-options: -fprof-auto 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++ + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m" -static -j -O cc-options: -DU_STATIC_IMPLEMENTATION=1 cpp-options: -DU_STATIC_IMPLEMENTATION=1 build-depends: base @@ -161,7 +145,6 @@ test-suite test , DiffSpec , SemanticSpec , SemanticCmdLineSpec - , GitmonClientSpec , InterpreterSpec , PatchOutputSpec , RangeSpec @@ -177,10 +160,7 @@ test-suite test , base , bifunctors , bytestring - , deepseq , filepath - , gitlib - , gitlib-libgit2 , Glob , haskell-tree-sitter , hspec >= 2.4.1 @@ -189,18 +169,13 @@ test-suite test , HUnit , leancheck , mtl - , network , protolude , containers , recursion-schemes >= 4.1 - , regex-compat , semantic-diff , text >= 1.2.1.3 - , text-icu - , unordered-containers , these - , vector - ghc-options: -threaded -rtsopts -with-rtsopts=-N -j -pgml=script/g++ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -j default-language: Haskell2010 default-extensions: DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards diff --git a/src/Algorithm.hs b/src/Algorithm.hs index fb049b0e0..cb23509f6 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -2,8 +2,10 @@ module Algorithm where import Control.Monad.Free.Freer +import Data.Functor.Classes import Data.These import Prologue hiding (liftF) +import Text.Show -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm. data AlgorithmF term diff result where @@ -61,3 +63,13 @@ byInserting = liftF . Insert -- | Replace one term with another. byReplacing :: term -> term -> Algorithm term diff diff byReplacing = (liftF .) . Replace + + +instance Show term => Show1 (AlgorithmF term diff) where + liftShowsPrec _ _ d algorithm = case algorithm of + Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2 + Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2 + RWS as bs -> showsBinaryWith showsPrec showsPrec "RWS" d as bs + Delete t1 -> showsUnaryWith showsPrec "Delete" d t1 + Insert t2 -> showsUnaryWith showsPrec "Insert" d t2 + Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2 diff --git a/src/Arguments.hs b/src/Arguments.hs index d600aebe8..a963d6def 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -3,59 +3,33 @@ module Arguments where import Data.Maybe -import Data.String import Language import Prologue import Renderer -data DiffMode = DiffStdin | DiffCommits String String [(FilePath, Maybe Language)] | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) +data DiffMode = DiffStdin | DiffPaths (FilePath, Maybe Language) (FilePath, Maybe Language) deriving Show data DiffArguments where DiffArguments :: (Monoid output, StringConv output ByteString) => { diffRenderer :: DiffRenderer output , diffMode :: DiffMode - , gitDir :: FilePath - , alternateObjectDirs :: [FilePath] } -> DiffArguments deriving instance Show DiffArguments -type DiffArguments' = DiffMode -> FilePath -> [FilePath] -> DiffArguments -patchDiff :: DiffArguments' -patchDiff = DiffArguments PatchDiffRenderer - -jsonDiff :: DiffArguments' -jsonDiff = DiffArguments JSONDiffRenderer - -sExpressionDiff :: DiffArguments' -sExpressionDiff = DiffArguments SExpressionDiffRenderer - -tocDiff :: DiffArguments' -tocDiff = DiffArguments ToCDiffRenderer - - -data ParseMode = ParseStdin | ParseCommit String [(FilePath, Maybe Language)] | ParsePaths [(FilePath, Maybe Language)] +data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)] deriving Show data ParseArguments where ParseArguments :: (Monoid output, StringConv output ByteString) => { parseTreeRenderer :: TermRenderer output , parseMode :: ParseMode - , gitDir :: FilePath - , alternateObjectDirs :: [FilePath] } -> ParseArguments deriving instance Show ParseArguments -type ParseArguments' = ParseMode -> FilePath -> [FilePath] -> ParseArguments - -sExpressionParseTree :: ParseArguments' -sExpressionParseTree = ParseArguments SExpressionTermRenderer - -jsonParseTree :: ParseArguments' -jsonParseTree = ParseArguments JSONTermRenderer data ProgramMode = Parse ParseArguments | Diff DiffArguments deriving Show diff --git a/src/Command.hs b/src/Command.hs index 48ef3ce51..8fcbcd26e 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -1,98 +1,5 @@ -{-# LANGUAGE DataKinds, GADTs #-} module Command -( Command --- Constructors -, readFile -, readBlobPairsFromHandle -, readBlobsFromHandle -, readFilesAtSHA -, readFilesAtSHAs --- Evaluation -, runCommand +( module Files ) where -import qualified Command.Files as Files -import qualified Command.Git as Git -import Control.Monad.Free.Freer -import Control.Monad.IO.Class -import Data.Functor.Both -import Data.Functor.Classes -import Data.String -import Prologue hiding (readFile) -import Language -import Source -import Text.Show - - --- | High-level commands encapsulating the work done to read blobs from the filesystem or Git. -type Command = Freer CommandF - - --- Constructors - --- | Read a file into a SourceBlob. -readFile :: FilePath -> Maybe Language -> Command SourceBlob -readFile path lang = ReadFile path lang `Then` return - --- | Read JSON encoded blob pairs to SourceBlobs. -readBlobPairsFromHandle :: Handle -> Command [Both SourceBlob] -readBlobPairsFromHandle h = ReadBlobPairsFromHandle h `Then` return - --- | Read JSON encoded blobs to SourceBlobs. -readBlobsFromHandle :: Handle -> Command [SourceBlob] -readBlobsFromHandle h = ReadBlobsFromHandle h `Then` return - --- | Read a list of files at the given commit SHA. -readFilesAtSHA :: FilePath -- ^ GIT_DIR - -> [FilePath] -- ^ GIT_ALTERNATE_OBJECT_DIRECTORIES - -> [(FilePath, Maybe Language)] -- ^ Specific paths. If empty, return changed paths. - -> String -- ^ The commit SHA. - -> Command [SourceBlob] -- ^ A command producing a list of pairs of blobs for the specified files (or all files if none were specified). -readFilesAtSHA gitDir alternates paths sha = ReadFilesAtSHA gitDir alternates paths sha `Then` return - --- | Read a list of files at the states corresponding to the given shas. -readFilesAtSHAs :: FilePath -- ^ GIT_DIR - -> [FilePath] -- ^ GIT_ALTERNATE_OBJECT_DIRECTORIES - -> [(FilePath, Maybe Language)] -- ^ Specific paths. If empty, return changed paths. - -> Both String -- ^ The commit shas for the before & after states. - -> Command [Both SourceBlob] -- ^ A command producing a list of pairs of blobs for the specified files (or all files if none were specified). -readFilesAtSHAs gitDir alternates paths shas = ReadFilesAtSHAs gitDir alternates paths shas `Then` return - - --- Evaluation - --- | Run the passed command and return its results in IO. -runCommand :: Command a -> IO a -runCommand = iterFreerA $ \ command yield -> case command of - ReadFile path lang -> Files.readFile path lang >>= yield - ReadBlobPairsFromHandle h -> Files.readBlobPairsFromHandle h >>= yield - ReadBlobsFromHandle h -> Files.readBlobsFromHandle h >>= yield - ReadFilesAtSHA gitDir alternates paths sha -> Git.readFilesAtSHA gitDir alternates paths sha >>= yield - ReadFilesAtSHAs gitDir alternates paths shas -> Git.readFilesAtSHAs gitDir alternates paths shas >>= yield - LiftIO io -> io >>= yield - - --- Implementation details - -data CommandF f where - ReadFile :: FilePath -> Maybe Language -> CommandF SourceBlob - ReadBlobPairsFromHandle :: Handle -> CommandF [Both SourceBlob] - ReadBlobsFromHandle :: Handle -> CommandF [SourceBlob] - ReadFilesAtSHA :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> String -> CommandF [SourceBlob] - ReadFilesAtSHAs :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> Both String -> CommandF [Both SourceBlob] - LiftIO :: IO a -> CommandF a - -instance MonadIO Command where - liftIO io = LiftIO io `Then` return - -instance Show1 CommandF where - liftShowsPrec _ _ d command = case command of - ReadFile path lang -> showsBinaryWith showsPrec showsPrec "ReadFile" d path lang - ReadBlobPairsFromHandle h -> showsUnaryWith showsPrec "ReadBlobPairsFromHandle" d h - ReadBlobsFromHandle h -> showsUnaryWith showsPrec "ReadBlobsFromHandle" d h - ReadFilesAtSHA gitDir alternates paths sha -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHA" d gitDir alternates paths sha - ReadFilesAtSHAs gitDir alternates paths shas -> showsQuaternaryWith showsPrec showsPrec showsPrec showsPrec "ReadFilesAtSHAs" d gitDir alternates paths shas - LiftIO _ -> showsUnaryWith (const showChar) "LiftIO" d '_' - 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 +import Command.Files as Files diff --git a/src/Command/Files.hs b/src/Command/Files.hs index afda94f3c..41dee0e21 100644 --- a/src/Command/Files.hs +++ b/src/Command/Files.hs @@ -3,7 +3,6 @@ module Command.Files ( readFile , readBlobPairsFromHandle , readBlobsFromHandle -, transcode , languageForFilePath ) where @@ -15,8 +14,7 @@ import Data.String import Language import Prologue hiding (readFile) import qualified Data.ByteString as B -import qualified Data.Text.ICU.Convert as Convert -import qualified Data.Text.ICU.Detect as Detect +import qualified Data.ByteString.Lazy as BL import Prelude (fail) import Source hiding (path) import System.FilePath @@ -26,15 +24,7 @@ import System.FilePath readFile :: FilePath -> Maybe Language -> IO SourceBlob readFile path language = do raw <- (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe ByteString)) - source <- traverse transcode raw - pure $ fromMaybe (emptySourceBlob path) (sourceBlob path language <$> source) - --- | Transcode a ByteString to a unicode Source. -transcode :: B.ByteString -> IO Source -transcode text = fromText <$> do - match <- Detect.detectCharset text - converter <- Convert.open match Nothing - pure $ Convert.toUnicode converter text + pure $ fromMaybe (emptySourceBlob path) (sourceBlob path language . Source <$> raw) -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported. languageForFilePath :: FilePath -> Maybe Language @@ -55,8 +45,8 @@ readBlobsFromHandle = fmap toSourceBlobs . readFromHandle readFromHandle :: FromJSON a => Handle -> IO a readFromHandle h = do - input <- B.hGetContents h - case decode (toS input) of + input <- BL.hGetContents h + case decode input of Just d -> pure d Nothing -> die ("invalid input on " <> show h <> ", expecting JSON") diff --git a/src/Command/Git.hs b/src/Command/Git.hs deleted file mode 100644 index e7662a7d7..000000000 --- a/src/Command/Git.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Command.Git -( readFilesAtSHA -, readFilesAtSHAs -) where - -import qualified Control.Concurrent.Async as Async -import Data.Functor.Both -import Data.String -import Data.List ((\\), nub) -import Prologue -import Git.Blob -import Git.Libgit2 -import Git.Libgit2.Backend -import Git.Repository -import Git.Types -import qualified Git -import GitmonClient -import Command.Files -import Language -import Source - --- | Read files at the specified commit SHA as blobs from a Git repo. -readFilesAtSHA :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> String -> IO [SourceBlob] -readFilesAtSHA gitDir alternates paths sha = runGit gitDir alternates $ do - tree <- treeForSha sha - traverse (uncurry (blobForPathInTree tree)) paths - --- | Read files at the specified commit SHA pair as blobs from a Git repo. -readFilesAtSHAs :: FilePath -> [FilePath] -> [(FilePath, Maybe Language)] -> Both String -> IO [Both SourceBlob] -readFilesAtSHAs gitDir alternates paths shas = do - paths <- case paths of - [] -> runGit' $ do - trees <- for shas treeForSha - paths <- for trees (reportGitmon "ls-tree" . treeBlobEntries) - pure . nub $! (\ (p, _, _) -> (toS p, languageForFilePath (toS p))) <$> runBothWith (\\) paths <> runBothWith (flip (\\)) paths - _ -> pure paths - - Async.mapConcurrently (runGit' . blobsForPath) paths - where - runGit' = runGit gitDir alternates - blobsForPath (path, lang) = do - trees <- traverse treeForSha shas - traverse (\t -> blobForPathInTree t path lang) trees - -runGit :: FilePath -> [FilePath] -> ReaderT LgRepo IO a -> IO a -runGit gitDir alternates action = withRepository lgFactory gitDir $ do - repo <- getRepository - for_ alternates (liftIO . odbBackendAddPath repo . toS) - action - -treeForSha :: String -> ReaderT LgRepo IO (Git.Tree LgRepo) -treeForSha sha = do - obj <- parseObjOid (toS sha) - commit <- reportGitmon "cat-file" $ lookupCommit obj - reportGitmon "cat-file" $ lookupTree (commitTree commit) - -blobForPathInTree :: Git.Tree LgRepo -> FilePath -> Maybe Language -> ReaderT LgRepo IO SourceBlob -blobForPathInTree tree path language = do - entry <- reportGitmon "ls-tree" $ treeEntry tree (toS path) - case entry of - Just (BlobEntry entryOid entryKind) -> do - blob <- reportGitmon "cat-file" $ lookupBlob entryOid - contents <- blobToByteString blob - transcoded <- liftIO $ transcode contents - let oid = renderObjOid $ blobOid blob - pure (SourceBlob transcoded (toS oid) path (Just (toSourceKind entryKind)) language) - _ -> pure (emptySourceBlob path) - where - toSourceKind :: Git.BlobKind -> SourceKind - toSourceKind (Git.PlainBlob mode) = Source.PlainBlob mode - toSourceKind (Git.ExecutableBlob mode) = Source.ExecutableBlob mode - toSourceKind (Git.SymlinkBlob mode) = Source.SymlinkBlob mode diff --git a/src/Data/Align/Generic.hs b/src/Data/Align/Generic.hs index eedf195f1..2fc20f824 100644 --- a/src/Data/Align/Generic.hs +++ b/src/Data/Align/Generic.hs @@ -10,38 +10,30 @@ import Prologue -- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type. class GAlign f where - galign :: f a -> f b -> Maybe (f (These a b)) - galign = galignWith identity - -- | Perform generic alignment of values of some functor, applying the given function to alignments of elements. galignWith :: (These a b -> c) -> f a -> f b -> Maybe (f c) default galignWith :: (Generic1 f, GAlign (Rep1 f)) => (These a b -> c) -> f a -> f b -> Maybe (f c) galignWith f a b = to1 <$> galignWith f (from1 a) (from1 b) +galign :: GAlign f => f a -> f b -> Maybe (f (These a b)) +galign = galignWith identity -- 'Data.Align.Align' instances instance GAlign [] where - galign = galignAlign galignWith = galignWithAlign instance GAlign Maybe where - galign = galignAlign galignWith = galignWithAlign instance GAlign Identity where galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b))) instance (GAlign f, GAlign (Union fs)) => GAlign (Union (f ': fs)) where - galign u1 u2 = case (decompose u1, decompose u2) of - (Left u1', Left u2') -> weaken <$> galign u1' u2' - (Right r1, Right r2) -> inj <$> galign r1 r2 - _ -> Nothing galignWith f u1 u2 = case (decompose u1, decompose u2) of (Left u1', Left u2') -> weaken <$> galignWith f u1' u2' (Right r1, Right r2) -> inj <$> galignWith f r1 r2 _ -> Nothing instance GAlign (Union '[]) where - galign _ _ = Nothing galignWith _ _ _ = Nothing -- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors. diff --git a/src/Data/Functor/Classes/Show/Generic.hs b/src/Data/Functor/Classes/Show/Generic.hs index 6b1780f29..e194aab19 100644 --- a/src/Data/Functor/Classes/Show/Generic.hs +++ b/src/Data/Functor/Classes/Show/Generic.hs @@ -17,9 +17,9 @@ class GShow1 f where -- | showsPrec function for an application of the type constructor based on showsPrec and showList functions for the argument type. gliftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS - -- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types. - gliftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS - gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0) +-- | showList function for an application of the type constructor based on showsPrec and showList functions for the argument type. The default implementation using standard list syntax is correct for most types. +gliftShowList :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS +gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0) -- | A suitable implementation of Show1’s liftShowsPrec for Generic1 types. genericLiftShowsPrec :: (Generic1 f, GShow1 (Rep1 f)) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index 8e31200e8..154e659d9 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -75,8 +75,8 @@ module Data.Syntax.Assignment , Result(..) , Error(..) , ErrorCause(..) -, showError -, showExpectation +, printError +, withSGRCode -- Running , assign , assignBy @@ -94,7 +94,6 @@ import qualified Data.IntMap.Lazy as IntMap import Data.Ix (inRange) import Data.List.NonEmpty (nonEmpty) import Data.Record -import Data.String import GHC.Stack import qualified Info import Prologue hiding (Alt, get, Location, state) @@ -103,6 +102,7 @@ import qualified Source (Source(..), drop, slice, sourceText, actualLines) import System.Console.ANSI import Text.Parser.TreeSitter.Language import Text.Show hiding (show) +import System.IO (hIsTerminalDevice, hPutStr) -- | Assignment from an AST with some set of 'symbol's onto some other value. -- @@ -181,18 +181,28 @@ data ErrorCause grammar deriving (Eq, Show) -- | Pretty-print an Error with reference to the source where it occurred. -showError :: Show grammar => Source.Source -> Error grammar -> String -showError source error@Error{..} - = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n' - . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') - . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n' - . showString (prettyCallStack callStack) - $ "" +printError :: Show grammar => Source.Source -> Error grammar -> IO () +printError source error@Error{..} + = do + withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . (showSourcePos Nothing errorPos) . showString ": " $ "" + withSGRCode [SetColor Foreground Vivid Red] . putStrErr . (showString "error") . showString ": " . showExpectation error . showChar '\n' . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') $ "" + withSGRCode [SetColor Foreground Vivid Green] . putStrErr . (showChar '^') . showChar '\n' . showString (prettyCallStack callStack) $ "" + where context = maybe "\n" (Source.sourceText . sconcat) (nonEmpty [ Source.Source (toS (showLineNumber i)) <> Source.Source ": " <> l | (i, l) <- zip [1..] (Source.actualLines source), inRange (Info.line errorPos - 2, Info.line errorPos) i ]) showLineNumber n = let s = show n in replicate (lineNumberDigits - length s) ' ' <> s lineNumberDigits = succ (floor (logBase 10 (fromIntegral (Info.line errorPos) :: Double))) - showSGRCode = showString . setSGRCode - withSGRCode code s = showSGRCode code . s . showSGRCode [] + putStrErr = hPutStr stderr + +withSGRCode :: [SGR] -> IO a -> IO () +withSGRCode code action = do + isTerm <- hIsTerminalDevice stderr + if isTerm then do + _ <- hSetSGR stderr code + _ <- action + hSetSGR stderr [] + else do + _ <- action + pure () showExpectation :: Show grammar => Error grammar -> ShowS showExpectation Error{..} = case errorCause of diff --git a/src/GitmonClient.hs b/src/GitmonClient.hs deleted file mode 100644 index fb23c465d..000000000 --- a/src/GitmonClient.hs +++ /dev/null @@ -1,168 +0,0 @@ --- | We use BangPatterns to force evaluation of git operations to preserve accuracy in measuring system stats (particularly disk read bytes) -{-# LANGUAGE RecordWildCards, DeriveGeneric, RankNTypes, BangPatterns #-} -module GitmonClient where - -import Control.Exception (throw) -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString.Lazy (toStrict) -import Data.Char (toLower) -import Data.Text (unpack, isInfixOf) -import qualified Data.Yaml as Y -import GHC.Generics -import Git.Libgit2 -import Network.Socket hiding (recv) -import Network.Socket.ByteString (sendAll, recv) -import Prelude -import Prologue hiding (toStrict, map, print, show) -import System.Clock -import System.Environment -import System.Timeout -import Text.Regex - -newtype GitmonException = GitmonException String deriving (Show, Typeable) - -instance Exception GitmonException - - -data ProcIO = ProcIO { readBytes :: Integer - , writeBytes :: Integer } deriving (Show, Generic) - -instance FromJSON ProcIO - -instance ToJSON ProcIO where - toJSON ProcIO{..} = object [ "read_bytes" .= readBytes, "write_bytes" .= writeBytes ] - - -data ProcessData = ProcessUpdateData { gitDir :: Maybe String - , program :: String - , realIP :: Maybe String - , repoName :: Maybe String - , repoID :: Maybe Int - , userID :: Maybe Int - , via :: String } - | ProcessScheduleData - | ProcessFinishData { cpu :: Integer - , diskReadBytes :: Integer - , diskWriteBytes :: Integer - , resultCode :: Integer } deriving (Generic, Show) - -instance ToJSON ProcessData where - toJSON ProcessUpdateData{..} = object [ "git_dir" .= gitDir, "program" .= program, "repo_name" .= repoName, "real_ip" .= realIP, "repo_id" .= repoID, "user_id" .= userID, "via" .= via ] - toJSON ProcessScheduleData = object [] - toJSON ProcessFinishData{..} = object [ "cpu" .= cpu, "disk_read_bytes" .= diskReadBytes, "disk_write_bytes" .= diskWriteBytes, "result_code" .= resultCode ] - - -data GitmonCommand = Update - | Finish - | Schedule deriving (Generic, Show) - -instance ToJSON GitmonCommand where - toJSON = genericToJSON defaultOptions { constructorTagModifier = map toLower } - - -data GitmonMsg = GitmonMsg { command :: GitmonCommand - , processData :: ProcessData } deriving (Show) - -instance ToJSON GitmonMsg where - toJSON GitmonMsg{..} = case command of - Update -> object ["command" .= ("update" :: String), "data" .= processData] - Finish -> object ["command" .= ("finish" :: String), "data" .= processData] - Schedule -> object ["command" .= ("schedule" :: String)] - - -type ProcInfo = Either Y.ParseException (Maybe ProcIO) - -newtype SocketFactory = SocketFactory { withSocket :: forall a. (Socket -> IO a) -> IO a } - -reportGitmon :: String -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a -reportGitmon = reportGitmon' SocketFactory { withSocket = withGitmonSocket } - -reportGitmon' :: SocketFactory -> String -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a -reportGitmon' SocketFactory{..} program gitCommand = - join . liftIO . withSocket $ \sock -> do - [gitDir, realIP, repoName, repoID, userID] <- traverse lookupEnv ["GIT_DIR", "GIT_SOCKSTAT_VAR_real_ip", "GIT_SOCKSTAT_VAR_repo_name", "GIT_SOCKSTAT_VAR_repo_id", "GIT_SOCKSTAT_VAR_user_id"] - void . safeGitmonIO . sendAll sock $ processJSON Update (ProcessUpdateData gitDir program realIP repoName (readIntFromEnv repoID) (readIntFromEnv userID) "semantic-diff") - void . safeGitmonIO . sendAll sock $ processJSON Schedule ProcessScheduleData - gitmonStatus <- safeGitmonIO $ recv sock 1024 - - (startTime, beforeProcIOContents) <- collectStats - -- | The result of the gitCommand is strictly evaluated (to next normal form). This is not equivalent to a `deepseq`. The underlying `Git.Types` do not have instances of `NFData` preventing us from using `deepseq` at this time. - let !result = withGitmonStatus gitmonStatus gitCommand - (afterTime, afterProcIOContents) <- collectStats - - let (cpuTime, diskReadBytes, diskWriteBytes, resultCode) = procStats startTime afterTime beforeProcIOContents afterProcIOContents - void . safeGitmonIO . sendAll sock $ processJSON Finish (ProcessFinishData cpuTime diskReadBytes diskWriteBytes resultCode) - pure result - - where - withGitmonStatus :: Maybe ByteString -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a - withGitmonStatus maybeGitmonStatus gitCommand = case maybeGitmonStatus of - Just gitmonStatus | "fail" `isInfixOf` decodeUtf8 gitmonStatus -> throwGitmonException gitmonStatus - _ -> gitCommand - - throwGitmonException :: ByteString -> e - throwGitmonException command = throw . GitmonException . unpack $ "Received: '" <> decodeUtf8 command <> "' from Gitmon" - - collectStats :: IO (TimeSpec, ProcInfo) - collectStats = do - time <- getTime clock - procIOContents <- Y.decodeFileEither procFileAddr :: IO ProcInfo - pure (time, procIOContents) - - procStats :: TimeSpec -> TimeSpec -> ProcInfo -> ProcInfo -> ( Integer, Integer, Integer, Integer ) - procStats beforeTime afterTime beforeProcIOContents afterProcIOContents = ( cpuTime, diskReadBytes, diskWriteBytes, resultCode ) - where - -- | toNanoSecs converts TimeSpec to Integer, and we further convert this value to milliseconds (expected by Gitmon). - cpuTime = div (1 * 1000 * 1000) . toNanoSecs $ afterTime - beforeTime - beforeDiskReadBytes = either (const 0) (maybe 0 readBytes) beforeProcIOContents - afterDiskReadBytes = either (const 0) (maybe 0 readBytes) afterProcIOContents - beforeDiskWriteBytes = either (const 0) (maybe 0 writeBytes) beforeProcIOContents - afterDiskWriteBytes = either (const 0) (maybe 0 writeBytes) afterProcIOContents - diskReadBytes = afterDiskReadBytes - beforeDiskReadBytes - diskWriteBytes = afterDiskWriteBytes - beforeDiskWriteBytes - resultCode = 0 - - readIntFromEnv :: Maybe String -> Maybe Int - readIntFromEnv Nothing = Nothing - readIntFromEnv (Just s) = readInt $ matchRegex regex s - where - -- | Expected format for userID and repoID is: "uint:123", - -- where "uint:" indicates an unsigned integer followed by an integer value. - regex :: Regex - regex = mkRegexWithOpts "^uint:([0-9]+)$" False True - - readInt :: Maybe [String] -> Maybe Int - readInt (Just [s]) = Just (read s :: Int) - readInt _ = Nothing - -withGitmonSocket :: (Socket -> IO c) -> IO c -withGitmonSocket = bracket connectSocket close - where - connectSocket = do - s <- socket AF_UNIX Stream defaultProtocol - void . safeGitmonIO $ connect s (SockAddrUnix gitmonSocketAddr) - pure s - --- | Timeout in nanoseconds to wait before giving up on Gitmon response to schedule. -gitmonTimeout :: Int -gitmonTimeout = 1 * 1000 * 1000 - -gitmonSocketAddr :: String -gitmonSocketAddr = "/tmp/gitstats.sock" - -safeGitmonIO :: MonadIO m => IO a -> m (Maybe a) -safeGitmonIO command = liftIO $ timeout gitmonTimeout command `catch` logError - -logError :: IOException -> IO (Maybe a) -logError _ = pure Nothing - -procFileAddr :: String -procFileAddr = "/proc/self/io" - -clock :: Clock -clock = Realtime - -processJSON :: GitmonCommand -> ProcessData -> ByteString -processJSON command processData = toStrict . encode $ GitmonMsg command processData - diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 751752bd4..ef776a633 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -33,13 +33,13 @@ diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparable -- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff. decoratingWith :: (Hashable label, Traversable f) => (forall a. TermF f (Record fields) a -> label) - -> (Both (Term f (Record (Maybe FeatureVector ': fields))) -> Diff f (Record (Maybe FeatureVector ': fields))) + -> (Both (Term f (Record (FeatureVector ': fields))) -> Diff f (Record (FeatureVector ': fields))) -> Both (Term f (Record fields)) -> Diff f (Record fields) decoratingWith getLabel differ = stripDiff . differ . fmap (defaultFeatureVectorDecorator getLabel) -- | Diff a pair of terms recurisvely, using the supplied continuation and 'ComparabilityRelation'. -diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fields (Maybe FeatureVector)) +diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fields FeatureVector) => (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) (Diff f (Record fields))) -- ^ A function producing syntax-directed continuations of the algorithm. -> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality. -> Both (Term f (Record fields)) -- ^ A pair of terms. diff --git a/src/Language/Go.hs b/src/Language/Go.hs index 699bee934..056ec25df 100644 --- a/src/Language/Go.hs +++ b/src/Language/Go.hs @@ -31,6 +31,7 @@ termAssignment source category children = case (category, children) of (SubscriptAccess, [a, b]) -> Just $ S.SubscriptAccess a b (IndexExpression, [a, b]) -> Just $ S.SubscriptAccess a b (Slice, [a, rest]) -> Just $ S.SubscriptAccess a rest + (Literal, children) -> Just . S.Indexed $ unpackElement <$> children (Other "composite_literal", [ty, values]) | ArrayTy <- Info.category (extract ty) -> Just $ S.Array (Just ty) (toList (unwrap values)) @@ -64,6 +65,10 @@ termAssignment source category children = case (category, children) of (Method, [receiverParams, name, params, ty, body]) -> Just (S.Method [] name (Just receiverParams) [params, ty] (toList (unwrap body))) _ -> Nothing + where unpackElement element + | Element <- Info.category (extract element) + , S.Indexed [ child ] <- unwrap element = child + | otherwise = element categoryForGoName :: Text -> Category categoryForGoName name = case name of diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index 1c9aba4d7..ac07dd67d 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -36,8 +36,8 @@ data Grammar | Image deriving (Bounded, Enum, Eq, Ord, Show) -cmarkParser :: Source -> IO (Cofree [] (Record (NodeType ': Location))) -cmarkParser source = pure . toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source) +cmarkParser :: Source -> Cofree [] (Record (NodeType ': Location)) +cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source) where toTerm :: Range -> SourceSpan -> Node -> Cofree [] (Record (NodeType ': Location)) toTerm within withinSpan (Node position t children) = let range = maybe within (sourceSpanToRange source . toSpan) position diff --git a/src/Parser.hs b/src/Parser.hs index d47e04379..730dd6cd8 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,5 +1,14 @@ {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} -module Parser where +module Parser +( Parser +, runParser +-- Syntax parsers +, parserForLanguage +-- À la carte parsers +, markdownParser +, pythonParser +, rubyParser +) where import qualified CMark import Data.Record @@ -17,6 +26,7 @@ import qualified Language.Ruby.Syntax as Ruby import Prologue hiding (Location) import Source import Syntax hiding (Go) +import System.IO (hPutStrLn) import System.Console.ANSI import Term import qualified Text.Parser.TreeSitter as TS @@ -34,7 +44,7 @@ data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (Cofree [] (Record (Maybe grammar ': Location))) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. Assignment errors will result in a top-level 'Syntax.Error' node. - AssignmentParser :: (Bounded grammar, Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error (Error grammar) :< fs, Traversable (Union fs), Recursive ast, Foldable (Base ast)) + AssignmentParser :: (Enum grammar, Eq grammar, Show grammar, Symbol grammar, Syntax.Error (Error grammar) :< fs, Foldable (Union fs), Functor (Union fs), Recursive ast, Foldable (Base ast)) => Parser ast -- ^ A parser producing AST. -> (forall x. Base ast x -> Record (Maybe grammar ': Location)) -- ^ A function extracting the symbol and location. -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. @@ -72,20 +82,18 @@ runParser parser = case parser of AssignmentParser parser by assignment -> \ source -> do ast <- runParser parser source let Result err term = assignBy by assignment source ast - traverse_ (putStrLn . showError source) (toList err) + traverse_ (printError source) (toList err) case term of Just term -> do let errors = termErrors term `asTypeOf` toList err - traverse_ (putStrLn . showError source) errors - unless (Prologue.null errors) $ - putStrLn (withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ "") + traverse_ (printError source) errors + unless (Prologue.null errors) $ do + withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] . hPutStrLn stderr . (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ "" pure term Nothing -> pure (errorTerm source err) TreeSitterParser language tslanguage -> treeSitterParser language tslanguage - MarkdownParser -> cmarkParser + MarkdownParser -> pure . cmarkParser LineByLineParser -> lineByLineParser - where showSGRCode = showString . setSGRCode - withSGRCode code s = showSGRCode code . s . showSGRCode [] errorTerm :: Syntax.Error (Error grammar) :< fs => Source -> Maybe (Error grammar) -> Term (Union fs) (Record Location) errorTerm source err = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error (fromMaybe (Error (SourcePos 0 0) (UnexpectedEndOfInput [])) err))) diff --git a/src/RWS.hs b/src/RWS.hs index 7a705c936..3a60d9c38 100644 --- a/src/RWS.hs +++ b/src/RWS.hs @@ -12,14 +12,13 @@ module RWS ( , defaultD ) where -import Prologue -import Control.Monad.Effect as Eff -import Control.Monad.Effect.Internal as I +import Prologue hiding (State, evalState, runState) +import Control.Monad.State.Strict import Data.Record import Data.These import Patch import Term -import Data.Array +import Data.Array.Unboxed import Data.Functor.Classes import SES import qualified Data.Functor.Both as Both @@ -39,50 +38,34 @@ type Label f fields label = forall b. TermF f (Record fields) b -> label -- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise. type ComparabilityRelation f fields = forall a b. TermF f (Record fields) a -> TermF f (Record fields) b -> Bool -type FeatureVector = Array Int Double +type FeatureVector = UArray Int Double -- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index. data UnmappedTerm f fields = UnmappedTerm { - termIndex :: Int -- ^ The index of the term within its root term. - , feature :: FeatureVector -- ^ Feature vector + termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term. + , feature :: {-# UNPACK #-} !FeatureVector -- ^ Feature vector , term :: Term f (Record fields) -- ^ The unmapped term } -- | Either a `term`, an index of a matched term, or nil. -data TermOrIndexOrNone term = Term term | Index Int | None +data TermOrIndexOrNone term = Term term | Index {-# UNPACK #-} !Int | None -rws :: (HasField fields (Maybe FeatureVector), Foldable t, Functor f, Eq1 f) +rws :: (HasField fields FeatureVector, Functor f, Eq1 f) => (Diff f fields -> Int) -> ComparabilityRelation f fields - -> t (Term f (Record fields)) - -> t (Term f (Record fields)) + -> [Term f (Record fields)] + -> [Term f (Record fields)] -> RWSEditScript f fields -rws editDistance canCompare as bs = Eff.run . RWS.run editDistance canCompare as bs $ do - sesDiffs <- ses' - (featureAs, featureBs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs' sesDiffs - (diffs, remaining) <- findNearestNeighoursToDiff' allDiffs featureAs featureBs - diffs' <- deleteRemaining' diffs remaining - rwsDiffs <- insertMapped' mappedDiffs diffs' - pure (fmap snd rwsDiffs) - -data RWS f fields result where - SES :: RWS f fields (RWSEditScript f fields) - - GenFeaturizedTermsAndDiffs :: HasField fields (Maybe FeatureVector) - => RWSEditScript f fields - -> RWS f fields - ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)]) - - FindNearestNeighoursToDiff :: [TermOrIndexOrNone (UnmappedTerm f fields)] - -> [UnmappedTerm f fields] - -> [UnmappedTerm f fields] - -> RWS f fields ([MappedDiff f fields], UnmappedTerms f fields) - - DeleteRemaining :: [MappedDiff f fields] - -> UnmappedTerms f fields - -> RWS f fields [MappedDiff f fields] - - InsertMapped :: [MappedDiff f fields] -> [MappedDiff f fields] -> RWS f fields [MappedDiff f fields] +rws _ _ as [] = This <$> as +rws _ _ [] bs = That <$> bs +rws _ canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a] +rws editDistance canCompare as bs = + let sesDiffs = ses (equalTerms canCompare) as bs + (featureAs, featureBs, mappedDiffs, allDiffs) = genFeaturizedTermsAndDiffs sesDiffs + (diffs, remaining) = findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs + diffs' = deleteRemaining diffs remaining + rwsDiffs = insertMapped mappedDiffs diffs' + in fmap snd rwsDiffs -- | An IntMap of unmapped terms keyed by their position in a list of terms. type UnmappedTerms f fields = IntMap (UnmappedTerm f fields) @@ -94,24 +77,6 @@ type MappedDiff f fields = (These Int Int, Diff f fields) type RWSEditScript f fields = [Diff f fields] -run :: (Eq1 f, Functor f, HasField fields (Maybe FeatureVector), Foldable t) - => (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. - -> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared. - -> t (Term f (Record fields)) - -> t (Term f (Record fields)) - -> Eff (RWS f fields ': e) (RWSEditScript f fields) - -> Eff e (RWSEditScript f fields) -run editDistance canCompare as bs = relay pure (\m q -> q $ case m of - SES -> ses (equalTerms canCompare) as bs - (GenFeaturizedTermsAndDiffs sesDiffs) -> - evalState (genFeaturizedTermsAndDiffs sesDiffs) (0, 0) - (FindNearestNeighoursToDiff allDiffs featureAs featureBs) -> - findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs - (DeleteRemaining allDiffs remainingDiffs) -> - deleteRemaining allDiffs remainingDiffs - (InsertMapped allDiffs mappedDiffs) -> - insertMapped allDiffs mappedDiffs) - insertMapped :: Foldable t => t (MappedDiff f fields) -> [MappedDiff f fields] -> [MappedDiff f fields] insertMapped diffs into = foldl' (flip insertDiff) into diffs @@ -170,10 +135,7 @@ findNearestNeighbourToDiff' :: (Diff f fields -> Int) -- ^ A function computes a findNearestNeighbourToDiff' editDistance canCompare kdTrees termThing = case termThing of None -> pure Nothing Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term - Index i -> do - (_, unA, unB) <- get - put (i, unA, unB) - pure Nothing + Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing -- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches. findNearestNeighbourTo :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms. @@ -239,37 +201,28 @@ insertion previous unmappedA unmappedB (UnmappedTerm j _ b) = do put (previous, unmappedA, IntMap.delete j unmappedB) pure (That j, That b) -genFeaturizedTermsAndDiffs :: (Functor f, HasField fields (Maybe FeatureVector)) +genFeaturizedTermsAndDiffs :: (Functor f, HasField fields FeatureVector) => RWSEditScript f fields - -> State - (Int, Int) - ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)]) -genFeaturizedTermsAndDiffs sesDiffs = case sesDiffs of - [] -> pure ([], [], [], []) - (diff : diffs) -> do - (counterA, counterB) <- get - case diff of - This term -> do - put (succ counterA, counterB) - (as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs - pure (featurize counterA term : as, bs, mappedDiffs, None : allDiffs ) - That term -> do - put (counterA, succ counterB) - (as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs - pure (as, featurize counterB term : bs, mappedDiffs, Term (featurize counterB term) : allDiffs) - These a b -> do - put (succ counterA, succ counterB) - (as, bs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs diffs - pure (as, bs, (These counterA counterB, These a b) : mappedDiffs, Index counterA : allDiffs) + -> ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)]) +genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d) + where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of + This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs) + That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (Term (featurize counterB term) : allDiffs) + These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs) -featurize :: (HasField fields (Maybe FeatureVector), Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields -featurize index term = UnmappedTerm index (let Just v = getField (extract term) in v) (eraseFeatureVector term) +data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)] -eraseFeatureVector :: (Functor f, HasField fields (Maybe FeatureVector)) => Term f (Record fields) -> Term f (Record fields) +featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields +featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term) + +eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields) eraseFeatureVector term = let record :< functor = runCofree term in - cofree (setFeatureVector record Nothing :< functor) + cofree (setFeatureVector record nullFeatureVector :< functor) -setFeatureVector :: HasField fields (Maybe FeatureVector) => Record fields -> Maybe FeatureVector -> Record fields +nullFeatureVector :: FeatureVector +nullFeatureVector = listArray (0, 0) [0] + +setFeatureVector :: HasField fields FeatureVector => Record fields -> FeatureVector -> Record fields setFeatureVector = setField minimumTermIndex :: [RWS.UnmappedTerm f fields] -> Int @@ -281,35 +234,6 @@ toMap = IntMap.fromList . fmap (termIndex &&& identity) toKdTree :: [UnmappedTerm f fields] -> KdTree Double (UnmappedTerm f fields) toKdTree = build (elems . feature) --- Effect constructors - -ses' :: (HasField fields (Maybe FeatureVector), RWS f fields :< e) => Eff e (RWSEditScript f fields) -ses' = send SES - -genFeaturizedTermsAndDiffs' :: (HasField fields (Maybe FeatureVector), RWS f fields :< e) - => RWSEditScript f fields - -> Eff e ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)]) -genFeaturizedTermsAndDiffs' = send . GenFeaturizedTermsAndDiffs - -findNearestNeighoursToDiff' :: (RWS f fields :< e) - => [TermOrIndexOrNone (UnmappedTerm f fields)] - -> [UnmappedTerm f fields] - -> [UnmappedTerm f fields] - -> Eff e ([MappedDiff f fields], UnmappedTerms f fields) -findNearestNeighoursToDiff' diffs as bs = send (FindNearestNeighoursToDiff diffs as bs) - -deleteRemaining' :: (RWS f fields :< e) - => [MappedDiff f fields] - -> UnmappedTerms f fields - -> Eff e [MappedDiff f fields] -deleteRemaining' diffs remaining = send (DeleteRemaining diffs remaining) - -insertMapped' :: (RWS f fields :< e) - => [MappedDiff f fields] - -> [MappedDiff f fields] - -> Eff e [MappedDiff f fields] -insertMapped' diffs mappedDiffs = send (InsertMapped diffs mappedDiffs) - -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree. data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] } deriving (Eq, Show) @@ -319,19 +243,19 @@ defaultFeatureVectorDecorator :: (Hashable label, Traversable f) => Label f fields label -> Term f (Record fields) - -> Term f (Record (Maybe FeatureVector ': fields)) + -> Term f (Record (FeatureVector ': fields)) defaultFeatureVectorDecorator getLabel = featureVectorDecorator getLabel defaultP defaultQ defaultD -- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions. -featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields label -> Int -> Int -> Int -> Term f (Record fields) -> Term f (Record (Maybe FeatureVector ': fields)) +featureVectorDecorator :: (Hashable label, Traversable f) => Label f fields label -> Int -> Int -> Int -> Term f (Record fields) -> Term f (Record (FeatureVector ': fields)) featureVectorDecorator getLabel p q d = cata collect . pqGramDecorator getLabel p q - where collect ((gram :. rest) :< functor) = cofree ((foldl' addSubtermVector (Just (unitVector d (hash gram))) functor :. rest) :< functor) - addSubtermVector :: Functor f => Maybe FeatureVector -> Term f (Record (Maybe FeatureVector ': fields)) -> Maybe FeatureVector - addSubtermVector v term = addVectors <$> v <*> rhead (extract term) + where collect ((gram :. rest) :< functor) = cofree ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor) + addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector + addSubtermVector v term = addVectors v (rhead (extract term)) - addVectors :: Num a => Array Int a -> Array Int a -> Array Int a + addVectors :: UArray Int Double -> UArray Int Double -> UArray Int Double addVectors as bs = listArray (0, d - 1) (fmap (\ i -> as ! i + bs ! i) [0..(d - 1)]) -- | Annotates a term with the corresponding p,q-gram at each node. @@ -364,11 +288,10 @@ pqGramDecorator getLabel p q = cata algebra -- | Computes a unit vector of the specified dimension from a hash. unitVector :: Int -> Int -> FeatureVector -unitVector d hash = fmap (* invMagnitude) uniform +unitVector d hash = listArray (0, d - 1) ((* invMagnitude) <$> components) where - uniform = listArray (0, d - 1) (evalRand components (pureMT (fromIntegral hash))) - invMagnitude = 1 / sqrtDouble (sum (fmap (** 2) uniform)) - components = sequenceA (replicate d (liftRand randomDouble)) + invMagnitude = 1 / sqrtDouble (sum (fmap (** 2) components)) + components = evalRand (sequenceA (replicate d (liftRand randomDouble))) (pureMT (fromIntegral hash)) -- | Test the comparability of two root 'Term's in O(1). canCompareTerms :: ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool diff --git a/src/Renderer.hs b/src/Renderer.hs index 09b58c372..10a35a672 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -7,7 +7,8 @@ module Renderer , renderSExpressionTerm , renderJSONDiff , renderJSONTerm -, renderToC +, renderToCDiff +, renderToCTerm , declarationAlgebra , markupSectionAlgebra , syntaxDeclarationAlgebra @@ -47,6 +48,8 @@ deriving instance Show (DiffRenderer output) -- | Specification of renderers for terms, producing output in the parameter type. data TermRenderer output where + -- | Compute a table of contents for the term & encode it as JSON. + ToCTermRenderer :: TermRenderer Summaries -- | Render to JSON with the format documented in docs/json-format.md under “Term.” JSONTermRenderer :: TermRenderer [Value] -- | Render to a 'ByteString' formatted as nested s-expressions. diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 329eb33e6..7be1327d6 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, RankNTypes, TypeOperators #-} module Renderer.TOC -( renderToC +( renderToCDiff +, renderToCTerm , diffTOC , Summaries(..) , JSONSummary(..) @@ -21,6 +22,7 @@ import Data.Align (crosswalk) import Data.Functor.Both hiding (fst, snd) import qualified Data.Functor.Both as Both import Data.Functor.Listable +import Data.List.NonEmpty (nonEmpty) import Data.Proxy import Data.Record import Data.Text (toLower) @@ -114,12 +116,12 @@ declarationAlgebra proxy source r where getSource = toText . flip Source.slice source . byteRange . extract -- | Compute 'Declaration's with the headings of 'Markup.Section's. -markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error error :< fs, HasField fields Range, Show error, Functor (Union fs)) +markupSectionAlgebra :: (Markup.Section :< fs, Syntax.Error error :< fs, HasField fields Range, Show error, Functor (Union fs), Foldable (Union fs)) => Proxy error -> Source -> RAlgebra (TermF (Union fs) (Record fields)) (Term (Union fs) (Record fields)) (Maybe Declaration) markupSectionAlgebra proxy source r - | Just (Markup.Section (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (getSource heading) + | Just (Markup.Section (heading, _) _) <- prj (tailF r) = Just $ SectionDeclaration (maybe (getSource heading) (toText . flip Source.slice source . sconcat) (nonEmpty (byteRange . extract <$> toList (unwrap heading)))) | Just (Syntax.Error err) <- prj (tailF r) = Just $ ErrorDeclaration (show (err `asProxyTypeOf` proxy)) | otherwise = Nothing where getSource = toText . flip Source.slice source . byteRange . extract @@ -140,15 +142,21 @@ tableOfContentsBy :: Traversable f => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f annotation -- ^ The diff to compute the table of contents for. -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. -tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (cata termAlgebra)) +tableOfContentsBy selector = fromMaybe [] . iter diffAlgebra . fmap (Just . fmap patchEntry . crosswalk (termTableOfContentsBy selector)) where diffAlgebra r = case (selector (first Both.snd r), fold r) of (Just a, Nothing) -> Just [Unchanged a] (Just a, Just []) -> Just [Changed a] (_ , entries) -> entries - termAlgebra r | Just a <- selector r = [a] - | otherwise = fold r patchEntry = these Deleted Inserted (const Replaced) . unPatch +termTableOfContentsBy :: Traversable f + => (forall b. TermF f annotation b -> Maybe a) + -> Term f annotation + -> [a] +termTableOfContentsBy selector = cata termAlgebra + where termAlgebra r | Just a <- selector r = [a] + | otherwise = fold r + dedupe :: HasField fields (Maybe Declaration) => [Entry (Record fields)] -> [Entry (Record fields)] dedupe = foldl' go [] where go xs x | (_, _:_) <- find (exactMatch `on` entryPayload) x xs = xs @@ -170,13 +178,16 @@ entrySummary entry = case entry of Deleted a -> recordSummary a "removed" Inserted a -> recordSummary a "added" Replaced a -> recordSummary a "modified" - where recordSummary record = case getDeclaration record of - Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record)) - Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record) - Nothing -> const Nothing -renderToC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Both SourceBlob -> Diff f (Record fields) -> Summaries -renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC +-- | Construct a 'JSONSummary' from a node annotation and a change type label. +recordSummary :: (HasField fields (Maybe Declaration), HasField fields SourceSpan) => Record fields -> Text -> Maybe JSONSummary +recordSummary record = case getDeclaration record of + Just (ErrorDeclaration text) -> Just . const (ErrorSummary text (sourceSpan record)) + Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record) + Nothing -> const Nothing + +renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Both SourceBlob -> Diff f (Record fields) -> Summaries +renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where toMap [] = mempty toMap as = Map.singleton summaryKey (toJSON <$> as) summaryKey = toS $ case runJoin (path <$> blobs) of @@ -185,9 +196,17 @@ renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValid | before == after -> after | otherwise -> before <> " -> " <> after +renderToCTerm :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => SourceBlob -> Term f (Record fields) -> Summaries +renderToCTerm blob = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC + where toMap [] = mempty + toMap as = Map.singleton (toS (path blob)) (toJSON <$> as) + diffTOC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Diff f (Record fields) -> [JSONSummary] diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration +termToC :: (HasField fields (Maybe Declaration), HasField fields SourceSpan, Traversable f) => Term f (Record fields) -> [JSONSummary] +termToC = mapMaybe (flip recordSummary "unchanged") . termTableOfContentsBy declaration + -- The user-facing category name toCategoryName :: Declaration -> Text toCategoryName declaration = case declaration of diff --git a/src/SES/Myers.hs b/src/SES/Myers.hs index 51465e7a1..b8c32fd2e 100644 --- a/src/SES/Myers.hs +++ b/src/SES/Myers.hs @@ -1,415 +1,71 @@ -{-# LANGUAGE GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-} module SES.Myers -( MyersF(..) -, EditScript -, Step(..) -, Myers -, EditGraph(..) -, Distance(..) -, Diagonal(..) -, Endpoint(..) +( EditScript , ses -, runMyers -, runMyersSteps -, lcs -, editDistance -, MyersState(..) ) where -import Control.Exception -import Control.Monad.Free.Freer +import Data.Array ((!)) import qualified Data.Array as Array import Data.Ix -import Data.Functor.Classes -import Data.String import Data.These import GHC.Show hiding (show) -import GHC.Stack -import Prologue hiding (for, State, error) -import qualified Prologue -import Text.Show (showListWith) - --- | Operations in Myers’ algorithm. -data MyersF a b result where - SES :: MyersF a b (EditScript a b) - LCS :: MyersF a b [(a, b)] - EditDistance :: MyersF a b Int - SearchUpToD :: Distance -> MyersF a b (Maybe (EditScript a b, Distance)) - SearchAlongK :: Distance -> Diagonal -> MyersF a b (Maybe (EditScript a b, Distance)) - MoveFromAdjacent :: Distance -> Diagonal -> MyersF a b (Endpoint a b) - MoveDownFrom :: Endpoint a b -> MyersF a b (Endpoint a b) - MoveRightFrom :: Endpoint a b -> MyersF a b (Endpoint a b) - SlideFrom :: Endpoint a b -> MyersF a b (Endpoint a b) - - GetK :: Diagonal -> MyersF a b (Endpoint a b) - SetK :: Diagonal -> Endpoint a b -> MyersF a b () - +import Prologue hiding (error) -- | An edit script, i.e. a sequence of changes/copies of elements. type EditScript a b = [These a b] --- | Steps in the execution of Myers’ algorithm, i.e. the sum of MyersF and State. -data Step a b result where - M :: HasCallStack => MyersF a b c -> Step a b c - S :: State (MyersState a b) c -> Step a b c - -type Myers a b = Freer (Step a b) - --- | Notionally the cartesian product of two sequences, represented as a simple wrapper around those arrays holding those sequences’ elements for O(1) lookups. -data EditGraph a b = EditGraph { as :: !(Array.Array Int a), bs :: !(Array.Array Int b) } +data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b } deriving (Eq, Show) --- | Construct an edit graph from Foldable sequences. -makeEditGraph :: (Foldable t, Foldable u) => t a -> u b -> EditGraph a b -makeEditGraph as bs = EditGraph (Array.listArray (0, pred (length as)) (toList as)) (Array.listArray (0, pred (length bs)) (toList bs)) - --- | An edit distance, i.e. a cardinal number of changes. -newtype Distance = Distance { unDistance :: Int } - deriving (Eq, Show) - --- | A diagonal in the edit graph of lists of lengths n and m, numbered from -m to n. -newtype Diagonal = Diagonal { unDiagonal :: Int } - deriving (Eq, Ix, Ord, Show) - --- | The endpoint of a path through the edit graph, represented as the x/y indices and the script of edits made to get to that point. -data Endpoint a b = Endpoint { x :: !Int, y :: !Int, script :: !(EditScript a b) } - deriving (Eq, Show) - - --- API -- | Compute the shortest edit script using Myers’ algorithm. -ses :: (HasCallStack, Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b -ses eq as bs = runMyers eq (makeEditGraph as bs) (M SES `Then` return) - - --- Evaluation - --- | Fully evaluate an operation in Myers’ algorithm given a comparator function and an edit graph. -runMyers :: forall a b c. HasCallStack => (a -> b -> Bool) -> EditGraph a b -> Myers a b c -> c -runMyers eq graph step = evalState (go step) (emptyStateForGraph graph) - where go :: forall c. Myers a b c -> Prologue.State (MyersState a b) c - go = iterFreerA algebra - algebra :: forall c x. Step a b x -> (x -> Prologue.State (MyersState a b) c) -> Prologue.State (MyersState a b) c - algebra step cont = case step of - M m -> go (decompose' m) >>= cont - S Get -> get >>= cont - S (Put s) -> put s >>= cont - decompose' :: forall c. MyersF a b c -> Myers a b c - decompose' = decompose eq graph - --- | Fully evaluate an operation in Myers’ algorithm given a comparator function and an edit graph, returning a list of states and next steps. -runMyersSteps :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> Myers a b c -> [(MyersState a b, Myers a b c)] -runMyersSteps eq graph = go (emptyStateForGraph graph) - where go state step = let ?callStack = popCallStack callStack in prefix state step $ case runMyersStep eq graph state step of - Left result -> [ (state, return result) ] - Right next -> uncurry go next - prefix state step = case step of - Then (M _) _ -> ((state, step) :) - _ -> identity - --- | Evaluate one step in Myers’ algorithm given a comparator function and an edit graph, returning Either the final result, or the next state and step. -runMyersStep :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> MyersState a b -> Myers a b c -> Either c (MyersState a b, Myers a b c) -runMyersStep eq graph state step = let ?callStack = popCallStack callStack in case step of - Return a -> Left a - Then step cont -> case step of - M myers -> Right (state, decompose eq graph myers >>= cont) - - S Get -> Right (state, cont state) - S (Put state') -> Right (state', cont ()) - - --- | Decompose an operation in Myers’ algorithm into its continuation. --- --- Dispatches to the per-operation run… functions which implement the meat of the algorithm. -decompose :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> MyersF a b c -> Myers a b c -decompose eq graph myers = let ?callStack = popCallStack callStack in case myers of - SES -> runSES graph - LCS -> runLCS graph - EditDistance -> runEditDistance graph - SearchUpToD d -> runSearchUpToD graph d - SearchAlongK d k -> runSearchAlongK graph d k - MoveFromAdjacent d k -> runMoveFromAdjacent graph d k - MoveDownFrom e -> runMoveDownFrom graph e - MoveRightFrom e -> runMoveRightFrom graph e - - GetK k -> runGetK graph k - SetK k x -> runSetK graph k x - - SlideFrom from -> runSlideFrom eq graph from -{-# INLINE decompose #-} - - --- | Compute the shortest edit script (diff) of an edit graph. -runSES :: HasCallStack => EditGraph a b -> Myers a b (EditScript a b) -runSES (EditGraph as bs) - | null bs = return (This <$> toList as) - | null as = return (That <$> toList bs) - | otherwise = let ?callStack = popCallStack callStack in do - result <- for [0..(length as + length bs)] (searchUpToD . Distance) - case result of - Just (script, _) -> return (reverse script) - _ -> fail "no shortest edit script found in edit graph (this is a bug in SES.Myers)." - --- | Compute the longest common subsequence of an edit graph. -runLCS :: HasCallStack => EditGraph a b -> Myers a b [(a, b)] -runLCS (EditGraph as bs) - | null as || null bs = return [] - | otherwise = let ?callStack = popCallStack callStack in do - result <- M SES `Then` return - return (catMaybes (these (const Nothing) (const Nothing) ((Just .) . (,)) <$> result)) - --- | Compute the edit distance of an edit graph. -runEditDistance :: HasCallStack => EditGraph a b -> Myers a b Int -runEditDistance _ = let ?callStack = popCallStack callStack in length . filter (these (const True) (const True) (const (const False))) <$> (M SES `Then` return) - - --- | Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches. -runSearchUpToD :: HasCallStack => EditGraph a b -> Distance -> Myers a b (Maybe (EditScript a b, Distance)) -runSearchUpToD (EditGraph as bs) (Distance d) = let ?callStack = popCallStack callStack in - for [ k | k <- [negate d, negate d + 2 .. d], inRange (negate m, n) k ] (searchAlongK (Distance d) . Diagonal) - where (n, m) = (length as, length bs) - --- | Search an edit graph for the shortest edit script along a specific diagonal. -runSearchAlongK :: HasCallStack => EditGraph a b -> Distance -> Diagonal -> Myers a b (Maybe (EditScript a b, Distance)) -runSearchAlongK (EditGraph as bs) d k = let ?callStack = popCallStack callStack in do - Endpoint x y script <- moveFromAdjacent d k - if x >= length as && y >= length bs then - return (Just (script, d)) - else - return Nothing - --- | Move onto a given diagonal from one of its in-bounds adjacent diagonals (if any), and slide down any diagonal edges eagerly. -runMoveFromAdjacent :: HasCallStack => EditGraph a b -> Distance -> Diagonal -> Myers a b (Endpoint a b) -runMoveFromAdjacent (EditGraph as bs) (Distance d) (Diagonal k) = let ?callStack = popCallStack callStack in do - let (n, m) = (length as, length bs) - from <- if d == 0 || k < negate m || k > n then - -- The top-left corner, or otherwise out-of-bounds. - return (Endpoint 0 0 []) - else if k == negate d || k == negate m then - -- The lower/left extent of the search region or edit graph, whichever is smaller. - getK (Diagonal (succ k)) >>= moveDownFrom - else if k /= d && k /= n then do - -- Somewhere in the interior of the search region and edit graph. - prev <- getK (Diagonal (pred k)) - next <- getK (Diagonal (succ k)) - if x prev < x next then - moveDownFrom next - else - moveRightFrom prev - else - -- The upper/right extent of the search region or edit graph, whichever is smaller. - getK (Diagonal (pred k)) >>= moveRightFrom - endpoint <- slideFrom from - setK (Diagonal k) endpoint - return endpoint - --- | Move downward from a given vertex, inserting the element for the corresponding row. -runMoveDownFrom :: HasCallStack => EditGraph a b -> Endpoint a b -> Myers a b (Endpoint a b) -runMoveDownFrom (EditGraph _ bs) (Endpoint x y script) = return (Endpoint x (succ y) (if y < length bs then That (bs ! y) : script else script)) - --- | Move rightward from a given vertex, deleting the element for the corresponding column. -runMoveRightFrom :: HasCallStack => EditGraph a b -> Endpoint a b -> Myers a b (Endpoint a b) -runMoveRightFrom (EditGraph as _) (Endpoint x y script) = return (Endpoint (succ x) y (if x < length as then This (as ! x) : script else script)) - --- | Return the maximum extent reached and path taken along a given diagonal. -runGetK :: HasCallStack => EditGraph a b -> Diagonal -> Myers a b (Endpoint a b) -runGetK graph k = let ?callStack = popCallStack callStack in do - v <- checkK graph k - let (x, script) = v ! k in return (Endpoint x (x - unDiagonal k) script) - --- | Update the maximum extent reached and path taken along a given diagonal. -runSetK :: HasCallStack => EditGraph a b -> Diagonal -> Endpoint a b -> Myers a b () -runSetK graph k (Endpoint x _ script) = let ?callStack = popCallStack callStack in do - v <- checkK graph k - put (MyersState (v Array.// [(k, (x, script))])) - --- | Slide down any diagonal edges from a given vertex. -runSlideFrom :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> Endpoint a b -> Myers a b (Endpoint a b) -runSlideFrom eq (EditGraph as bs) (Endpoint x y script) - | x >= 0, x < length as - , y >= 0, y < length bs - , a <- as ! x - , b <- bs ! y - , a `eq` b = slideFrom (Endpoint (succ x) (succ y) (These a b : script)) - | otherwise = return (Endpoint x y script) - - --- Smart constructors - --- | Compute the longest common subsequence. -lcs :: HasCallStack => Myers a b [(a, b)] -lcs = M LCS `Then` return - --- | Compute the edit distance. -editDistance :: HasCallStack => Myers a b Int -editDistance = M EditDistance `Then` return - --- | Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches. -searchUpToD :: HasCallStack => Distance -> Myers a b (Maybe (EditScript a b, Distance)) -searchUpToD distance = M (SearchUpToD distance) `Then` return - --- | Search an edit graph for the shortest edit script along a specific diagonal. -searchAlongK :: HasCallStack => Distance -> Diagonal -> Myers a b (Maybe (EditScript a b, Distance)) -searchAlongK d k = M (SearchAlongK d k) `Then` return - --- | Move onto a given diagonal from one of its in-bounds adjacent diagonals (if any), and slide down any diagonal edges eagerly. -moveFromAdjacent :: HasCallStack => Distance -> Diagonal -> Myers a b (Endpoint a b) -moveFromAdjacent d k = M (MoveFromAdjacent d k) `Then` return - --- | Move downward from a given vertex, inserting the element for the corresponding row. -moveDownFrom :: HasCallStack => Endpoint a b -> Myers a b (Endpoint a b) -moveDownFrom e = M (MoveDownFrom e) `Then` return - --- | Move rightward from a given vertex, deleting the element for the corresponding column. -moveRightFrom :: HasCallStack => Endpoint a b -> Myers a b (Endpoint a b) -moveRightFrom e = M (MoveRightFrom e) `Then` return - --- | Return the maximum extent reached and path taken along a given diagonal. -getK :: HasCallStack => Diagonal -> Myers a b (Endpoint a b) -getK diagonal = M (GetK diagonal) `Then` return - --- | Update the maximum extent reached and path taken along a given diagonal. -setK :: HasCallStack => Diagonal -> Endpoint a b -> Myers a b () -setK diagonal x = M (SetK diagonal x) `Then` return - --- | Slide down any diagonal edges from a given vertex. -slideFrom :: HasCallStack => Endpoint a b -> Myers a b (Endpoint a b) -slideFrom from = M (SlideFrom from) `Then` return - - --- Implementation details - --- | The state stored by Myers’ algorithm; an array of m + n + 1 values indicating the maximum x-index reached and path taken along each diagonal. -newtype MyersState a b = MyersState { unMyersState :: Array.Array Diagonal (Int, EditScript a b) } - deriving (Eq, Show) - --- | State effect used in Myers. -data State s a where - Get :: State s s - Put :: s -> State s () - --- | Compute the empty state of length m + n + 1 for a given edit graph. -emptyStateForGraph :: EditGraph a b -> MyersState a b -emptyStateForGraph (EditGraph as bs) = let (n, m) = (length as, length bs) in - MyersState (Array.listArray (Diagonal (negate m), Diagonal n) (repeat (0, []))) - --- | Evaluate some function for each value in a list until one returns a value or the list is exhausted. -for :: [a] -> (a -> Myers c d (Maybe b)) -> Myers c d (Maybe b) -for all run = foldr (\ a b -> (<|>) <$> run a <*> b) (return Nothing) all - - --- | Throw a failure. Used to indicate an error in the implementation of Myers’ algorithm. -fail :: (HasCallStack, Monad m) => String -> m a -fail s = let ?callStack = fromCallSiteList (filter ((/= "M") . fst) (getCallStack callStack)) in - throw (MyersException s callStack) - --- | Bounds-checked indexing of arrays, preserving the call stack. -(!) :: (HasCallStack, Ix i, Show i) => Array.Array i a -> i -> a -v ! i | inRange (Array.bounds v) i = v Array.! i - | otherwise = let ?callStack = fromCallSiteList (filter ((/= "M") . fst) (getCallStack callStack)) in - throw (MyersException ("index " <> show i <> " out of bounds") callStack) - --- | Check that a given diagonal is in-bounds for the edit graph, returning the actual index to use and the state array. -checkK :: HasCallStack => EditGraph a b -> Diagonal -> Myers a b (Array.Array Diagonal (Int, EditScript a b)) -checkK _ k = let ?callStack = popCallStack callStack in do - v <- gets unMyersState - unless (inRange (Array.bounds v) k) $ fail ("diagonal " <> show k <> " outside state bounds " <> show (Array.bounds v)) - return v - - --- | Lifted showing of arrays. -liftShowsVector :: Show i => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array.Array i a -> ShowS -liftShowsVector sp sl d = liftShowsPrec sp sl d . toList - --- | Lifted showing of operations in Myers’ algorithm. -liftShowsMyersF :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> MyersF a b c -> ShowS -liftShowsMyersF sp1 sp2 d m = case m of - SES -> showString "SES" - LCS -> showString "LCS" - EditDistance -> showString "EditDistance" - SearchUpToD distance -> showsUnaryWith showsPrec "SearchUpToD" d distance - SearchAlongK distance diagonal -> showsBinaryWith showsPrec showsPrec "SearchAlongK" d distance diagonal - MoveFromAdjacent distance diagonal -> showsBinaryWith showsPrec showsPrec "MoveFromAdjacent" d distance diagonal - MoveDownFrom endpoint -> showsUnaryWith (liftShowsEndpoint sp1 sp2) "MoveDownFrom" d endpoint - MoveRightFrom endpoint -> showsUnaryWith (liftShowsEndpoint sp1 sp2) "MoveRightFrom" d endpoint - GetK diagonal -> showsUnaryWith showsPrec "GetK" d diagonal - SetK diagonal v -> showsBinaryWith showsPrec (liftShowsEndpoint sp1 sp2) "SetK" d diagonal v - SlideFrom endpoint -> showsUnaryWith (liftShowsEndpoint sp1 sp2) "SlideFrom" d endpoint - --- | Lifted showing of ternary constructors. -showsTernaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> (Int -> c -> ShowS) -> String -> Int -> a -> b -> c -> ShowS -showsTernaryWith sp1 sp2 sp3 name d x y z = showParen (d > 10) $ - showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y . showChar ' ' . sp3 11 z - --- | Lifted showing of State. -liftShowsState :: (Int -> a -> ShowS) -> Int -> State a b -> ShowS -liftShowsState sp d state = case state of - Get -> showString "Get" - Put s -> showsUnaryWith sp "Put" d s - --- | Lift value/list showing functions into a showing function for steps in Myers’ algorithm. -liftShowsStep :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> Step a b c -> ShowS -liftShowsStep sp1 sl1 sp2 sl2 d step = case step of - M m -> showsUnaryWith (liftShowsMyersF sp1 sp2) "M" d m - S s -> showsUnaryWith (liftShowsState (liftShowsPrec2 sp1 sl1 sp2 sl2)) "S" d s - --- | Lifted showing of These. -liftShowsThese :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> These a b -> ShowS -liftShowsThese sa sb d t = case t of - This a -> showsUnaryWith sa "This" d a - That b -> showsUnaryWith sb "That" d b - These a b -> showsBinaryWith sa sb "These" d a b - --- | Lifted showing of edit scripts. -liftShowsEditScript :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> EditScript a b -> ShowS -liftShowsEditScript sa sb _ = showListWith (liftShowsThese sa sb 0) - --- | Lifted showing of edit graph endpoints. -liftShowsEndpoint :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> Int -> Endpoint a b -> ShowS -liftShowsEndpoint sp1 sp2 d (Endpoint x y script) = showsTernaryWith showsPrec showsPrec (liftShowsEditScript sp1 sp2) "Endpoint" d x y script - --- | Exceptions in Myers’ algorithm, along with a description and call stack. -data MyersException = MyersException String CallStack - deriving (Typeable) - - --- Instances - -instance MonadState (MyersState a b) (Myers a b) where - get = S Get `Then` return - put a = S (Put a) `Then` return - -instance Show2 MyersState where - liftShowsPrec2 sp1 _ sp2 _ d (MyersState v) = showsUnaryWith showsStateVector "MyersState" d v - where showsStateVector = showsWith liftShowsVector (showsWith liftShowsPrec (liftShowsEditScript sp1 sp2)) - showsWith g f = g f (showListWith (f 0)) - -instance Show s => Show1 (State s) where - liftShowsPrec _ _ = liftShowsState showsPrec - -instance Show s => Show (State s a) where - showsPrec = liftShowsPrec (const (const identity)) (const identity) - -instance Show2 EditGraph where - liftShowsPrec2 sp1 sl1 sp2 sl2 d (EditGraph as bs) = showsBinaryWith (liftShowsVector sp1 sl1) (liftShowsVector sp2 sl2) "EditGraph" d as bs - -instance Show2 Endpoint where - liftShowsPrec2 sp1 _ sp2 _ = liftShowsEndpoint sp1 sp2 - -instance (Show a, Show b) => Show1 (MyersF a b) where - liftShowsPrec _ _ = liftShowsMyersF showsPrec showsPrec - -instance (Show a, Show b) => Show (MyersF a b c) where - showsPrec = liftShowsMyersF showsPrec showsPrec - -instance (Show a, Show b) => Show1 (Step a b) where - liftShowsPrec _ _ = liftShowsStep showsPrec showList showsPrec showList - -instance (Show a, Show b) => Show (Step a b c) where - showsPrec = liftShowsStep showsPrec showList showsPrec showList - -instance Exception MyersException - -instance Show MyersException where - showsPrec _ (MyersException s c) = showString "Exception: " . showString s . showChar '\n' . showString (prettyCallStack c) +ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b +ses eq as' bs' + | null bs = This <$> toList as + | null as = That <$> toList bs + | otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])])) + where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs')) + (!n, !m) = (length as', length bs') + + -- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches. + searchUpToD !d !v = + let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in + case find isComplete endpoints of + Just (Endpoint _ _ script) -> script + _ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints)) + where isComplete (Endpoint x y _) = x >= n && y >= m + + -- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any). + searchAlongK !k + | k == -d = moveDownFrom (v ! succ k) + | k == d = moveRightFrom (v ! pred k) + | k == -m = moveDownFrom (v ! succ k) + | k == n = moveRightFrom (v ! pred k) + | otherwise = + let left = v ! pred k + up = v ! succ k in + if x left < x up then + moveDownFrom up + else + moveRightFrom left + + -- | Move downward from a given vertex, inserting the element for the corresponding row. + moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . That) (bs !? y) + {-# INLINE moveDownFrom #-} + + -- | Move rightward from a given vertex, deleting the element for the corresponding column. + moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . This) (as !? x) + {-# INLINE moveRightFrom #-} + + -- | Slide down any diagonal edges from a given vertex. + slideFrom (Endpoint x y script) + | Just a <- as !? x + , Just b <- bs !? y + , a `eq` b = slideFrom (Endpoint (succ x) (succ y) (These a b : script)) + | otherwise = Endpoint x y script + + +(!?) :: Ix i => Array.Array i a -> i -> Maybe a +(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a + | otherwise = Nothing +{-# INLINE (!?) #-} diff --git a/src/Semantic.hs b/src/Semantic.hs index fa2a1952f..9ef476ab8 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -45,6 +45,9 @@ parseBlobs renderer = fmap toS . distributeFoldMap (parseBlob renderer) . filter -- | A task to parse a 'SourceBlob' and render the resulting 'Term'. parseBlob :: TermRenderer output -> SourceBlob -> Task output parseBlob renderer blob@SourceBlob{..} = case (renderer, blobLanguage) of + (ToCTermRenderer, Just Language.Markdown) -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source) >>= render (renderToCTerm blob) + (ToCTermRenderer, Just Language.Python) -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a) >>= render (renderToCTerm blob) + (ToCTermRenderer, _) -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source) >>= render (renderToCTerm blob) (JSONTermRenderer, Just Language.Markdown) -> parse markdownParser source >>= render (renderJSONTerm blob) (JSONTermRenderer, Just Language.Python) -> parse pythonParser source >>= render (renderJSONTerm blob) (JSONTermRenderer, _) -> parse syntaxParser source >>= decorate identifierAlgebra >>= render (renderJSONTerm blob) @@ -57,15 +60,16 @@ parseBlob renderer blob@SourceBlob{..} = case (renderer, blobLanguage) of where syntaxParser = parserForLanguage blobLanguage + diffBlobPairs :: (Monoid output, StringConv output ByteString) => DiffRenderer output -> [Both SourceBlob] -> Task ByteString diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) . filter (any blobExists) -- | A task to parse a pair of 'SourceBlob's, diff them, and render the 'Diff'. diffBlobPair :: DiffRenderer output -> Both SourceBlob -> Task output diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of - (ToCDiffRenderer, Just Language.Markdown) -> run (\ source -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source)) diffLinearly (renderToC blobs) - (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToC blobs) - (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToC blobs) + (ToCDiffRenderer, Just Language.Markdown) -> run (\ source -> parse markdownParser source >>= decorate (markupSectionAlgebra (Proxy :: Proxy Markdown.Error) source)) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, Just Language.Python) -> run (\ source -> parse pythonParser source >>= decorate (declarationAlgebra (Proxy :: Proxy Python.Error) source) . hoistCofree (weaken :: Union fs a -> Union (Declaration.Method ': fs) a)) diffLinearly (renderToCDiff blobs) + (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToCDiff blobs) (JSONDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffLinearly (renderJSONDiff blobs) (JSONDiffRenderer, _) -> run (decorate identifierAlgebra <=< parse syntaxParser) diffTerms (renderJSONDiff blobs) diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 2b79ae6fc..d0d7b59ff 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -6,41 +6,28 @@ import Command import Command.Files (languageForFilePath) 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 Renderer import qualified Data.ByteString as B import qualified Paths_semantic_diff as Library (version) import qualified Semantic.Task as Task import System.Directory -import System.Environment import System.FilePath.Posix (takeFileName, (-<.>)) -import System.IO.Error (IOError) import System.IO (stdin) -import Text.Regex import qualified Semantic (parseBlobs, diffBlobPairs) main :: IO () main = do - gitDir <- findGitDir - alternates <- findAlternates - Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates) + Arguments{..} <- customExecParser (prefs showHelpOnEmpty) arguments outputPath <- traverse 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 path = do isDir <- doesDirectoryExist path pure $ if isDir then takeFileName path -<.> ".html" else path @@ -49,28 +36,25 @@ main = do runDiff :: DiffArguments -> IO ByteString runDiff DiffArguments{..} = do - blobs <- runCommand $ case diffMode of + blobs <- case diffMode of DiffPaths a b -> pure <$> traverse (uncurry readFile) (both a b) - DiffCommits sha1 sha2 paths -> readFilesAtSHAs gitDir alternateObjectDirs paths (both sha1 sha2) DiffStdin -> readBlobPairsFromHandle stdin Task.runTask (Semantic.diffBlobPairs diffRenderer blobs) runParse :: ParseArguments -> IO ByteString runParse ParseArguments{..} = do - blobs <- runCommand $ case parseMode of + blobs <- case parseMode of ParsePaths paths -> traverse (uncurry readFile) paths - ParseCommit sha paths -> readFilesAtSHA gitDir alternateObjectDirs paths sha ParseStdin -> readBlobsFromHandle stdin Task.runTask (Semantic.parseBlobs parseTreeRenderer blobs) -- | A parser for the application's command-line arguments. -arguments :: FilePath -> [FilePath] -> ParserInfo Arguments -arguments gitDir alternates = info (version <*> helper <*> argumentsParser) description +arguments :: ParserInfo Arguments +arguments = 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" + description = fullDesc <> header "semantic -- Parse and diff semantically" argumentsParser = Arguments <$> hsubparser (diffCommand <> parseCommand) @@ -78,39 +62,23 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths")) diffArgumentsParser = Diff - <$> ( ( flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)") - <|> flag' jsonDiff (long "json" <> help "Output a json diff") - <|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree") - <|> flag' tocDiff (long "toc" <> help "Output a table of contents for a diff") ) + <$> ( ( flag (DiffArguments PatchDiffRenderer) (DiffArguments PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)") + <|> flag' (DiffArguments JSONDiffRenderer) (long "json" <> help "Output a json diff") + <|> flag' (DiffArguments SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree") + <|> flag' (DiffArguments ToCDiffRenderer) (long "toc" <> help "Output a table of contents for a diff") ) <*> ( DiffPaths <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (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 filePathReader (metavar "FILES...")) - <|> pure DiffStdin ) - <*> pure gitDir - <*> pure alternates ) + <|> pure DiffStdin )) - parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths")) + parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)")) parseArgumentsParser = Parse - <$> ( ( flag sExpressionParseTree sExpressionParseTree (long "sexpression" <> help "Output s-expression parse trees (default)") - <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees") ) + <$> ( ( flag (ParseArguments SExpressionTermRenderer) (ParseArguments SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") + <|> flag' (ParseArguments JSONTermRenderer) (long "json" <> help "Output JSON parse trees") + <|> flag' (ParseArguments ToCTermRenderer) (long "toc" <> help "Output a table of contents for a file")) <*> ( ParsePaths <$> some (argument filePathReader (metavar "FILES...")) - <|> ParseCommit - <$> option (eitherReader parseSha) (long "sha" <> metavar "SHA" <> help "Commit SHA") - <*> some (argument filePathReader (metavar "FILES...")) - <|> pure ParseStdin ) - <*> 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 + <|> pure ParseStdin )) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of diff --git a/src/TreeSitter.hs b/src/TreeSitter.hs index 4786bdc30..c1aab154e 100644 --- a/src/TreeSitter.hs +++ b/src/TreeSitter.hs @@ -72,11 +72,11 @@ safeToEnum n | (fromEnum (minBound :: n), fromEnum (maxBound :: n)) `inRange` n -- | Return a parser for a tree sitter language & document. documentToTerm :: Language -> Ptr Document -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) -documentToTerm language document source = do +documentToTerm language document allSource = do root <- alloca (\ rootPtr -> do ts_document_root_node_p document rootPtr peek rootPtr) - toTerm root source + toTerm root (slice (nodeRange root) allSource) where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record DefaultFields)) toTerm node source = do name <- peekCString (nodeType node) diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs index 4e2b80860..1953f09b0 100644 --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -1,18 +1,12 @@ module CommandSpec where import Command -import Data.Aeson import Data.Functor.Both as Both -import Data.Map as Map import Data.Maybe import Data.String import Language import Prologue hiding (readFile, toList) -import qualified Git.Types as Git -import Renderer hiding (errors) import Source -import Semantic -import Semantic.Task import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty @@ -20,11 +14,11 @@ spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - blob <- runCommand (readFile "semantic-diff.cabal" Nothing) + blob <- readFile "semantic-diff.cabal" Nothing path blob `shouldBe` "semantic-diff.cabal" it "returns a nullBlob for absent files" $ do - blob <- runCommand (readFile "this file should not exist" Nothing) + blob <- readFile "this file should not exist" Nothing nullBlob blob `shouldBe` True describe "readBlobPairsFromHandle" $ do @@ -53,7 +47,7 @@ spec = parallel $ do it "returns blobs for unsupported language" $ do h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode - blobs <- runCommand (readBlobPairsFromHandle h) + blobs <- readBlobPairsFromHandle h let b' = sourceBlob "test.kt" Nothing "fun main(args: Array) {\nprintln(\"hi\")\n}\n" blobs `shouldBe` [both (emptySourceBlob "test.kt") b'] @@ -63,79 +57,26 @@ spec = parallel $ do it "throws on blank input" $ do h <- openFile "test/fixtures/input/blank.json" ReadMode - runCommand (readBlobPairsFromHandle h) `shouldThrow` (== ExitFailure 1) + readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1) it "throws if language field not given" $ do h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode - runCommand (readBlobsFromHandle h) `shouldThrow` (== ExitFailure 1) + readBlobsFromHandle h `shouldThrow` (== ExitFailure 1) describe "readBlobsFromHandle" $ do it "returns blobs for valid JSON encoded parse input" $ do h <- openFile "test/fixtures/input/parse.json" ReadMode - blobs <- runCommand (readBlobsFromHandle h) + blobs <- readBlobsFromHandle h let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" blobs `shouldBe` [a] it "throws on blank input" $ do h <- openFile "test/fixtures/input/blank.json" ReadMode - runCommand (readBlobsFromHandle h) `shouldThrow` (== ExitFailure 1) + readBlobsFromHandle h `shouldThrow` (== ExitFailure 1) - describe "readFilesAtSHA" $ do - it "returns blobs for the specified paths" $ do - blobs <- runCommand (readFilesAtSHA repoPath [] [("methods.rb", Just Ruby)] (Both.snd (shas methodsFixture))) - blobs `shouldBe` [methodsBlob] - - it "returns emptySourceBlob if path doesn't exist at sha" $ do - blobs <- runCommand (readFilesAtSHA repoPath [] [("methods.rb", Just Ruby)] (Both.fst (shas methodsFixture))) - blobExists <$> blobs `shouldBe` [False] - - describe "readFilesAtSHAs" $ do - it "returns blobs for the specified paths" $ do - blobs <- runCommand (readFilesAtSHAs repoPath [] [("methods.rb", Just Ruby)] (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", Nothing)] (shas methodsFixture)) - let b = emptySourceBlob "this file should not exist" - blobs `shouldBe` [both b b] - - describe "fetchDiffs" $ do - it "generates toc summaries for two shas" $ do - Summaries summaries errors <- fetchDiffsOutput "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] - errors `shouldBe` fromList [] - summaries `shouldBe` fromList [("methods.rb", [methodsObject])] - - it "generates toc summaries for two shas inferring paths" $ do - Summaries summaries errors <- fetchDiffsOutput "test/fixtures/git/examples/all-languages.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [] - errors `shouldBe` fromList [] - summaries `shouldBe` fromList [("methods.rb", [methodsObject])] - - it "errors with bad shas" $ - fetchDiffsOutput "test/fixtures/git/examples/all-languages.git" "dead" "beef" [("methods.rb", Just Ruby)] - `shouldThrow` (== Git.BackendError "Could not lookup dead: Object not found - no match for prefix (dead000000000000000000000000000000000000)") - - it "errors with bad repo path" $ - fetchDiffsOutput "test/fixtures/git/examples/not-a-repo.git" "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] - `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") - [ both (emptySourceBlob "methods.rb") methodsBlob ] - methodsBlob = SourceBlob (Source "def foo\nend\n") "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) (Just Ruby) - methodsObject = object [ "span" .= object [ "start" .= [ 1, 1 :: Int ], "end" .= [ 2, 4 :: Int ] ], "category" .= ("Method" :: Text), "term" .= ("foo" :: Text), "changeType" .= ("added" :: Text) ] - blobsFromFilePath path = do + where blobsFromFilePath path = do h <- openFile path ReadMode - blobs <- runCommand (readBlobPairsFromHandle h) + blobs <- readBlobPairsFromHandle h pure blobs data Fixture = Fixture { shas :: Both String, expectedBlobs :: [Both SourceBlob] } - -fetchDiffsOutput :: FilePath -> String -> String -> [(FilePath, Maybe Language)] -> IO Summaries -fetchDiffsOutput gitDir sha1 sha2 filePaths = do - blobPairs <- runCommand $ readFilesAtSHAs gitDir [] filePaths (both sha1 sha2) - runTask (distributeFoldMap (Semantic.diffBlobPair Renderer.ToCDiffRenderer) blobPairs) diff --git a/test/Data/RandomWalkSimilarity/Spec.hs b/test/Data/RandomWalkSimilarity/Spec.hs index 07692d9f2..b4537a84c 100644 --- a/test/Data/RandomWalkSimilarity/Spec.hs +++ b/test/Data/RandomWalkSimilarity/Spec.hs @@ -2,6 +2,7 @@ module Data.RandomWalkSimilarity.Spec where import Category +import Data.Array.IArray import Data.Bifunctor import Data.Functor.Listable import RWS @@ -29,7 +30,7 @@ spec = parallel $ do describe "featureVectorDecorator" $ do prop "produces a vector of the specified dimension" $ - \ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== positively d) . maybe 0 length . rhead) + \ (term, p, q, d) -> featureVectorDecorator (rhead . headF) (positively p) (positively q) (positively d) (unListableF term :: SyntaxTerm String '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead) describe "rws" $ do prop "produces correct diffs" $ @@ -45,7 +46,7 @@ spec = parallel $ do where canCompare a b = headF a == headF b - decorate :: SyntaxTerm leaf '[Category] -> SyntaxTerm leaf '[Maybe FeatureVector, Category] + decorate :: SyntaxTerm leaf '[Category] -> SyntaxTerm leaf '[FeatureVector, Category] decorate = defaultFeatureVectorDecorator (category . headF) diffThese = these deleting inserting replacing diff --git a/test/GitmonClientSpec.hs b/test/GitmonClientSpec.hs deleted file mode 100644 index e6779344c..000000000 --- a/test/GitmonClientSpec.hs +++ /dev/null @@ -1,193 +0,0 @@ -module GitmonClientSpec where - -import Control.Exception -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString.Char8 (ByteString, pack, unpack) -import Data.Foldable -import Data.HashMap.Lazy (empty) -import Data.Maybe (fromMaybe) -import Data.Text hiding (empty) -import Git.Libgit2 -import Git.Repository -import Git.Types hiding (Object) -import GitmonClient -import Network.Socket hiding (recv) -import Network.Socket.ByteString -import Prelude hiding (lookup) -import Prologue (liftIO, runReaderT) -import System.Environment (setEnv) -import Test.Hspec hiding (shouldBe, shouldSatisfy, shouldThrow, anyErrorCall) -import Test.Hspec.Expectations.Pretty -import Text.Regex - -spec :: Spec -spec = - describe "gitmon" $ do - let wd = "test/fixtures/git/examples/all-languages.git" - realIP' = "127.0.0.1" - repoName' = "examples/all-languages" - - it "receives commands in order" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ sendAll server "continue" - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, scheduleData, finishData] = infoToCommands info - - liftIO $ do - shouldBe (commitOid commit) object - shouldBe updateData (Just "update") - shouldBe scheduleData (Just "schedule") - shouldBe finishData (Just "finish") - - it "receives update command with correct data" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ do - traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:10"), ("GIT_SOCKSTAT_VAR_user_id", "uint:20")] - sendAll server "continue" - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, _, finishData] = infoToData info - - liftIO $ do - shouldBe (commitOid commit) object - shouldBe (either Just gitDir updateData) (Just wd) - shouldBe (either id program updateData) "cat-file" - shouldBe (either Just realIP updateData) (Just "127.0.0.1") - shouldBe (either Just repoName updateData) (Just "examples/all-languages") - shouldBe (either (const $ Just 1) repoID updateData) (Just 10) - shouldBe (either (const $ Just 1) userID updateData) (Just 20) - shouldBe (either id via updateData) "semantic-diff" - - shouldSatisfy (either (const (-1)) cpu finishData) (>= 0) - shouldSatisfy (either (const (-1)) diskReadBytes finishData) (>= 0) - shouldSatisfy (either (const (-1)) diskWriteBytes finishData) (>= 0) - shouldSatisfy (either (const (-1)) resultCode finishData) (>= 0) - - it "reads Nothing for user_id and repo_id when valid prefix but invalid value" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ do - traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:not_valid"), ("GIT_SOCKSTAT_VAR_user_id", "uint:not_valid")] - sendAll server "continue" - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, _, _] = infoToData info - - liftIO $ do - shouldBe (either (const $ Just 1) repoID updateData) Nothing - shouldBe (either (const $ Just 1) userID updateData) Nothing - - it "reads Nothing for user_id and repo_id when valid prefix but value is preceeded by invalid chars" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ do - traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:abc100"), ("GIT_SOCKSTAT_VAR_user_id", "uint:abc100")] - sendAll server "continue" - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, _, _] = infoToData info - - liftIO $ do - shouldBe (either (const $ Just 1) repoID updateData) Nothing - shouldBe (either (const $ Just 1) userID updateData) Nothing - - it "reads Nothing for user_id and repo_id when valid prefix but value is proceeded by invalid chars" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ do - traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:100abc"), ("GIT_SOCKSTAT_VAR_user_id", "uint:100abc")] - sendAll server "continue" - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, _, _] = infoToData info - - liftIO $ do - shouldBe (either (const $ Just 1) repoID updateData) Nothing - shouldBe (either (const $ Just 1) userID updateData) Nothing - - it "reads Nothing for user_id and repo_id when missing prefix but value is valid" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ do - traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "100"), ("GIT_SOCKSTAT_VAR_user_id", "100")] - sendAll server "continue" - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - let [updateData, _, _] = infoToData info - - liftIO $ do - shouldBe (either (const $ Just 1) repoID updateData) Nothing - shouldBe (either (const $ Just 1) userID updateData) Nothing - - it "returns the correct git result if the socket is unavailable" . withSocketPair $ \(client, server, socketFactory) -> - withRepository lgFactory wd $ do - liftIO $ close client - - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object - info <- liftIO $ recv server 1024 - - liftIO $ shouldBe (commitOid commit) object - liftIO $ shouldBe "" info - - it "throws if schedule response is fail" . withSocketPair $ \(_, server, socketFactory) -> - withRepository lgFactory wd $ do - repo <- getRepository - liftIO $ sendAll server "fail too busy" - object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2") - - liftIO $ shouldThrow (runReaderT (reportGitmon' socketFactory "cat-file" (lookupCommit object)) repo) gitmonException - -gitmonException :: GitmonException -> Bool -gitmonException = const True - -withSocketPair :: ((Socket, Socket, SocketFactory) -> IO c) -> IO c -withSocketPair = bracket create release - where - create = do - (client, server) <- socketPair AF_UNIX Stream defaultProtocol - pure (client, server, SocketFactory (\f -> f client)) - release (client, server, _) = do - close client - close server - -infoToCommands :: ByteString -> [Maybe Text] -infoToCommands input = command' . toObject <$> extract regex input - where - command' :: Object -> Maybe Text - command' = parseMaybe (.: "command") - -infoToData :: ByteString -> [Either String ProcessData] -infoToData input = data' . toObject <$> extract regex input - where - data' = parseEither parser - parser o = do - dataO <- o .: "data" - asum [ ProcessUpdateData <$> (dataO .: "git_dir") <*> (dataO .: "program") <*> (dataO .:? "real_ip") <*> (dataO .:? "repo_name") <*> (dataO .:? "repo_id") <*> (dataO .:? "user_id") <*> (dataO .: "via") - , ProcessFinishData <$> (dataO .: "cpu") <*> (dataO .: "disk_read_bytes") <*> (dataO .: "disk_write_bytes") <*> (dataO .: "result_code") - , pure ProcessScheduleData - ] - -toObject :: ByteString -> Object -toObject input = fromMaybe empty (decodeStrict input) - -regex :: Regex -regex = mkRegexWithOpts "(\\{.*\"update\".*\"\\}\\})(\\{.*\"schedule\"\\})(\\{.*\"finish\".*\\}\\})" False True - -extract :: Regex -> ByteString -> [ByteString] -extract regex input = Data.ByteString.Char8.pack <$> fromMaybe [""] (matchRegex regex (Data.ByteString.Char8.unpack input)) diff --git a/test/SemanticCmdLineSpec.hs b/test/SemanticCmdLineSpec.hs index b5104308f..6991faa81 100644 --- a/test/SemanticCmdLineSpec.hs +++ b/test/SemanticCmdLineSpec.hs @@ -4,20 +4,22 @@ module SemanticCmdLineSpec where import Prologue import Arguments import Language +import Renderer import SemanticCmdLine -import Data.Functor.Listable import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) import Test.Hspec.Expectations.Pretty -import Test.Hspec.LeanCheck spec :: Spec spec = parallel $ do - prop "runDiff for all modes and formats" $ - \ DiffFixture{..} -> do + describe "runDiff" $ + for_ diffFixtures $ \ (arguments@DiffArguments{..}, expected) -> + it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do output <- runDiff arguments output `shouldBe'` expected - prop "runParse for all modes and formats" $ - \ ParseFixture{..} -> do + + describe "runParse" $ + for_ parseFixtures $ \ (arguments@ParseArguments{..}, expected) -> + it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do output <- runParse arguments output `shouldBe'` expected where @@ -25,33 +27,23 @@ spec = parallel $ do when (actual /= expected) $ print actual actual `shouldBe` expected +parseFixtures :: [(ParseArguments, ByteString)] +parseFixtures = + [ (ParseArguments SExpressionTermRenderer pathMode, sExpressionParseTreeOutput) + , (ParseArguments JSONTermRenderer pathMode, jsonParseTreeOutput) + , (ParseArguments JSONTermRenderer pathMode', jsonParseTreeOutput') + , (ParseArguments JSONTermRenderer (ParsePaths []), emptyJsonParseTreeOutput) + , (ParseArguments JSONTermRenderer (ParsePaths [("not-a-file.rb", Just Ruby)]), emptyJsonParseTreeOutput) + , (ParseArguments ToCTermRenderer (ParsePaths [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)]), tocOutput) + ] + where pathMode = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby)] + pathMode' = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)] -data ParseFixture = ParseFixture - { arguments :: ParseArguments - , expected :: ByteString - } deriving (Show) - -instance Listable ParseFixture where - tiers = cons0 (ParseFixture (sExpressionParseTree pathMode "" []) sExpressionParseTreeOutput) - \/ cons0 (ParseFixture (jsonParseTree pathMode "" []) jsonParseTreeOutput) - \/ cons0 (ParseFixture (jsonParseTree pathMode' "" []) jsonParseTreeOutput') - \/ cons0 (ParseFixture (sExpressionParseTree commitMode repo []) "(Program\n (Method\n (Identifier)))\n") - \/ cons0 (ParseFixture (jsonParseTree commitMode repo []) jsonParseTreeOutput'') - \/ cons0 (ParseFixture (jsonParseTree (ParseCommit "2e4144eb8c44f007463ec34cb66353f0041161fe" []) repo []) emptyJsonParseTreeOutput) - \/ cons0 (ParseFixture (jsonParseTree (ParsePaths []) repo []) emptyJsonParseTreeOutput) - \/ cons0 (ParseFixture (jsonParseTree (ParseCommit "2e4144eb8c44f007463ec34cb66353f0041161fe" [("not-a-file.rb", Just Ruby)]) repo []) emptyJsonParseTreeOutput) - \/ cons0 (ParseFixture (jsonParseTree (ParsePaths [("not-a-file.rb", Just Ruby)]) repo []) emptyJsonParseTreeOutput) - - where - pathMode = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby)] - pathMode' = ParsePaths [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)] - commitMode = ParseCommit "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] - - sExpressionParseTreeOutput = "(Program\n (Binary\n (Identifier)\n (Other \"and\")\n (Identifier)))\n" - 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\":\"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]}},\"language\":\"Ruby\"}]\n" - 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\":\"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]}},\"language\":\"Ruby\"},{\"filePath\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[4,6],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,7]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"Binary\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[13,15],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,5]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[18,21],\"sourceSpan\":{\"start\":[2,8],\"end\":[2,11]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]\n" - jsonParseTreeOutput'' = "[{\"filePath\":\"methods.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}],\"identifier\":\"foo\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]\n" - emptyJsonParseTreeOutput = "[]\n" + sExpressionParseTreeOutput = "(Program\n (Binary\n (Identifier)\n (Other \"and\")\n (Identifier)))\n" + 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\":\"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]}},\"language\":\"Ruby\"}]\n" + 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\":\"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]}},\"language\":\"Ruby\"},{\"filePath\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[4,6],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,7]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"Binary\",\"children\":[{\"category\":\"Binary\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"or\",\"children\":[],\"sourceRange\":[13,15],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,5]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"and\",\"children\":[],\"sourceRange\":[18,21],\"sourceSpan\":{\"start\":[2,8],\"end\":[2,11]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]\n" + emptyJsonParseTreeOutput = "[]\n" + tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"unchanged\"}]},\"errors\":{}}\n" data DiffFixture = DiffFixture @@ -59,29 +51,20 @@ data DiffFixture = DiffFixture , expected :: ByteString } deriving (Show) -instance Listable DiffFixture where - tiers = cons0 (DiffFixture (patchDiff pathMode "" []) patchOutput) - \/ cons0 (DiffFixture (jsonDiff pathMode "" []) jsonOutput) - \/ cons0 (DiffFixture (sExpressionDiff pathMode "" []) sExpressionOutput) - \/ cons0 (DiffFixture (tocDiff pathMode "" []) tocOutput) - \/ cons0 (DiffFixture (patchDiff commitMode repo []) patchOutput') - \/ cons0 (DiffFixture (jsonDiff commitMode repo []) jsonOutput') - \/ cons0 (DiffFixture (sExpressionDiff commitMode repo []) sExpressionOutput') - \/ cons0 (DiffFixture (tocDiff commitMode repo []) tocOutput') +diffFixtures :: [(DiffArguments, ByteString)] +diffFixtures = + [ (DiffArguments PatchDiffRenderer pathMode, patchOutput) + , (DiffArguments JSONDiffRenderer pathMode, jsonOutput) + , (DiffArguments SExpressionDiffRenderer pathMode, sExpressionOutput) + , (DiffArguments ToCDiffRenderer pathMode, tocOutput) + ] + where pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby) - where - pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby) - commitMode = DiffCommits "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe" [("methods.rb", Just Ruby)] + 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" - 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" - patchOutput' = "diff --git a/methods.rb b/methods.rb\nnew file mode 100644\nindex 0000000000000000000000000000000000000000..ff7bbbe9495f61d9e1e58c597502d152bab1761e\n--- /dev/null\n+++ b/methods.rb\n+def foo\n+end\n\n" - - jsonOutput = "{\"diff\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"after\":{\"category\":\"Method\",\"identifier\":\"bar\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]},{\"insert\":{\"category\":\"Params\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}],\"sourceRange\":[7,13],\"sourceSpan\":{\"start\":[1,8],\"end\":[2,3]}}},{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}],\"before\":{\"category\":\"Method\",\"identifier\":\"foo\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}},\"oids\":[\"0000000000000000000000000000000000000000\",\"0000000000000000000000000000000000000000\"],\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n" - jsonOutput' = "{\"diff\":{\"insert\":{\"category\":\"Program\",\"children\":[{\"category\":\"Method\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}],\"identifier\":\"foo\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}},\"oids\":[\"0000000000000000000000000000000000000000\",\"ff7bbbe9495f61d9e1e58c597502d152bab1761e\"],\"paths\":[\"methods.rb\",\"methods.rb\"]}\n" - sExpressionOutput = "(Program\n (Method\n { (Identifier)\n ->(Identifier) }\n {+(Params\n (Identifier))+}\n {+(Identifier)+}))\n" - sExpressionOutput' = "{+(Program\n (Method\n (Identifier)))+}\n" - 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" - tocOutput' = "{\"changes\":{\"methods.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"foo\",\"changeType\":\"added\"}]},\"errors\":{}}\n" + jsonOutput = "{\"diff\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"after\":{\"category\":\"Method\",\"identifier\":\"bar\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]},{\"insert\":{\"category\":\"Params\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}],\"sourceRange\":[7,13],\"sourceSpan\":{\"start\":[1,8],\"end\":[2,3]}}},{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}],\"before\":{\"category\":\"Method\",\"identifier\":\"foo\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}},\"oids\":[\"0000000000000000000000000000000000000000\",\"0000000000000000000000000000000000000000\"],\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n" + sExpressionOutput = "(Program\n (Method\n { (Identifier)\n ->(Identifier) }\n {+(Params\n (Identifier))+}\n {+(Identifier)+}))\n" + 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" repo :: FilePath repo = "test/fixtures/git/examples/all-languages.git" diff --git a/test/Spec.hs b/test/Spec.hs index 25921b472..c90513c5d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,7 +7,6 @@ import qualified Data.Mergeable.Spec import qualified Data.RandomWalkSimilarity.Spec import qualified Data.Syntax.Assignment.Spec import qualified DiffSpec -import qualified GitmonClientSpec import qualified InterpreterSpec import qualified PatchOutputSpec import qualified RangeSpec @@ -39,6 +38,3 @@ main = hspec $ do describe "SemanticCmdLine" SemanticCmdLineSpec.spec describe "TOC" TOCSpec.spec describe "Integration" IntegrationSpec.spec - - - describe "GitmonClient" GitmonClientSpec.spec diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 4ff676efc..f48fd1494 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -10,8 +10,6 @@ module SpecHelpers import qualified Data.ByteString as B import Data.Functor.Both import Data.Functor.Listable -import qualified Data.Text.ICU.Convert as Convert -import qualified Data.Text.ICU.Detect as Detect import Diff import Language import Patch @@ -42,18 +40,8 @@ parseFilePath path = do -- the filesystem or Git. The tests, however, will still leverage reading files. readFile :: FilePath -> IO SourceBlob readFile path = do - source <- (Just <$> readFileToUnicode path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe Source)) + source <- (Just . Source <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe Source)) pure $ fromMaybe (emptySourceBlob path) (sourceBlob path (languageForFilePath path) <$> source) - where - -- | Read a file, convert it's contents unicode and return it wrapped in Source. - readFileToUnicode :: FilePath -> IO Source - readFileToUnicode path = B.readFile path >>= transcode - where - transcode :: B.ByteString -> IO Source - transcode text = fromText <$> do - match <- Detect.detectCharset text - converter <- Convert.open match Nothing - pure $ Convert.toUnicode converter text -- | Returns a Maybe Language based on the FilePath's extension. languageForFilePath :: FilePath -> Maybe Language diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 0578f7613..28e1db7f0 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -94,6 +94,11 @@ spec = parallel $ do diffTOC diff `shouldBe` [ JSONSummary "Method" "foo" (sourceSpanBetween (6, 1) (7, 4)) "added" ] + it "properly slices source blob that starts with a newline and has multi-byte chars" $ do + sourceBlobs <- blobsForPaths (both "javascript/starts-with-newline.js" "javascript/starts-with-newline.js") + Just diff <- runTask (diffBlobPair IdentityDiffRenderer sourceBlobs) + diffTOC diff `shouldBe` [] + prop "inserts of methods and functions are summarized" $ \name body -> let diff = programWithInsert name (unListableF body) diff --git a/test/fixtures/git/examples/all-languages.git/HEAD b/test/fixtures/git/examples/all-languages.git/HEAD deleted file mode 100644 index cb089cd89..000000000 --- a/test/fixtures/git/examples/all-languages.git/HEAD +++ /dev/null @@ -1 +0,0 @@ -ref: refs/heads/master diff --git a/test/fixtures/git/examples/all-languages.git/config b/test/fixtures/git/examples/all-languages.git/config deleted file mode 100644 index e6da23157..000000000 --- a/test/fixtures/git/examples/all-languages.git/config +++ /dev/null @@ -1,6 +0,0 @@ -[core] - repositoryformatversion = 0 - filemode = true - bare = true - ignorecase = true - precomposeunicode = true diff --git a/test/fixtures/git/examples/all-languages.git/hooks/post-receive b/test/fixtures/git/examples/all-languages.git/hooks/post-receive deleted file mode 100755 index 576dd319d..000000000 --- a/test/fixtures/git/examples/all-languages.git/hooks/post-receive +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh -# -# Aggressively pack example repos in fixtures - -exec git gc --agressive diff --git a/test/fixtures/git/examples/all-languages.git/info/refs b/test/fixtures/git/examples/all-languages.git/info/refs deleted file mode 100644 index 32b2def30..000000000 --- a/test/fixtures/git/examples/all-languages.git/info/refs +++ /dev/null @@ -1 +0,0 @@ -2e4144eb8c44f007463ec34cb66353f0041161fe refs/heads/master diff --git a/test/fixtures/git/examples/all-languages.git/objects/info/packs b/test/fixtures/git/examples/all-languages.git/objects/info/packs deleted file mode 100644 index 11d0a61fd..000000000 --- a/test/fixtures/git/examples/all-languages.git/objects/info/packs +++ /dev/null @@ -1,2 +0,0 @@ -P pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.pack - diff --git a/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.idx b/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.idx deleted file mode 100644 index 1673d98e6..000000000 Binary files a/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.idx and /dev/null differ diff --git a/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.pack b/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.pack deleted file mode 100644 index dfd30b7dd..000000000 Binary files a/test/fixtures/git/examples/all-languages.git/objects/pack/pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.pack and /dev/null differ diff --git a/test/fixtures/git/examples/all-languages.git/packed-refs b/test/fixtures/git/examples/all-languages.git/packed-refs deleted file mode 100644 index 6f852a254..000000000 --- a/test/fixtures/git/examples/all-languages.git/packed-refs +++ /dev/null @@ -1,2 +0,0 @@ -# pack-refs with: peeled fully-peeled -2e4144eb8c44f007463ec34cb66353f0041161fe refs/heads/master diff --git a/test/fixtures/go/array-with-implicit-length.diff+A.txt b/test/fixtures/go/array-with-implicit-length.diff+A.txt index a6a8e54c0..ab1924beb 100644 --- a/test/fixtures/go/array-with-implicit-length.diff+A.txt +++ b/test/fixtures/go/array-with-implicit-length.diff+A.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral))))))))+} + (NumberLiteral) + (NumberLiteral) + (NumberLiteral)))))))+} diff --git a/test/fixtures/go/array-with-implicit-length.diff+B.txt b/test/fixtures/go/array-with-implicit-length.diff+B.txt index a6a8e54c0..ab1924beb 100644 --- a/test/fixtures/go/array-with-implicit-length.diff+B.txt +++ b/test/fixtures/go/array-with-implicit-length.diff+B.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral))))))))+} + (NumberLiteral) + (NumberLiteral) + (NumberLiteral)))))))+} diff --git a/test/fixtures/go/array-with-implicit-length.diff-A.txt b/test/fixtures/go/array-with-implicit-length.diff-A.txt index e6e1f292a..5a345abdd 100644 --- a/test/fixtures/go/array-with-implicit-length.diff-A.txt +++ b/test/fixtures/go/array-with-implicit-length.diff-A.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral))))))))-} + (NumberLiteral) + (NumberLiteral) + (NumberLiteral)))))))-} diff --git a/test/fixtures/go/array-with-implicit-length.diff-B.txt b/test/fixtures/go/array-with-implicit-length.diff-B.txt index e6e1f292a..5a345abdd 100644 --- a/test/fixtures/go/array-with-implicit-length.diff-B.txt +++ b/test/fixtures/go/array-with-implicit-length.diff-B.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral))))))))-} + (NumberLiteral) + (NumberLiteral) + (NumberLiteral)))))))-} diff --git a/test/fixtures/go/array-with-implicit-length.diffA-B.txt b/test/fixtures/go/array-with-implicit-length.diffA-B.txt index 0fc98ecc8..bdf13b0d0 100644 --- a/test/fixtures/go/array-with-implicit-length.diffA-B.txt +++ b/test/fixtures/go/array-with-implicit-length.diffA-B.txt @@ -12,12 +12,9 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - { (NumberLiteral) - ->(NumberLiteral) }) - (Element - { (NumberLiteral) - ->(NumberLiteral) }) - (Element - { (NumberLiteral) - ->(NumberLiteral) }))))))) + { (NumberLiteral) + ->(NumberLiteral) } + { (NumberLiteral) + ->(NumberLiteral) } + {+(NumberLiteral)+} + {-(NumberLiteral)-})))))) diff --git a/test/fixtures/go/array-with-implicit-length.diffB-A.txt b/test/fixtures/go/array-with-implicit-length.diffB-A.txt index 0fc98ecc8..bdf13b0d0 100644 --- a/test/fixtures/go/array-with-implicit-length.diffB-A.txt +++ b/test/fixtures/go/array-with-implicit-length.diffB-A.txt @@ -12,12 +12,9 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - { (NumberLiteral) - ->(NumberLiteral) }) - (Element - { (NumberLiteral) - ->(NumberLiteral) }) - (Element - { (NumberLiteral) - ->(NumberLiteral) }))))))) + { (NumberLiteral) + ->(NumberLiteral) } + { (NumberLiteral) + ->(NumberLiteral) } + {+(NumberLiteral)+} + {-(NumberLiteral)-})))))) diff --git a/test/fixtures/go/array-with-implicit-length.parseA.txt b/test/fixtures/go/array-with-implicit-length.parseA.txt index 7263a80aa..80ae6c6b5 100644 --- a/test/fixtures/go/array-with-implicit-length.parseA.txt +++ b/test/fixtures/go/array-with-implicit-length.parseA.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)))))))) + (NumberLiteral) + (NumberLiteral) + (NumberLiteral))))))) diff --git a/test/fixtures/go/array-with-implicit-length.parseB.txt b/test/fixtures/go/array-with-implicit-length.parseB.txt index 7263a80aa..80ae6c6b5 100644 --- a/test/fixtures/go/array-with-implicit-length.parseB.txt +++ b/test/fixtures/go/array-with-implicit-length.parseB.txt @@ -12,9 +12,6 @@ (Other "composite_literal" (ArrayTy (Identifier)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)) - (Element - (NumberLiteral)))))))) + (NumberLiteral) + (NumberLiteral) + (NumberLiteral))))))) diff --git a/test/fixtures/go/slice-literals.diff+A.txt b/test/fixtures/go/slice-literals.diff+A.txt index 034e4dd3c..916f4af27 100644 --- a/test/fixtures/go/slice-literals.diff+A.txt +++ b/test/fixtures/go/slice-literals.diff+A.txt @@ -22,8 +22,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -33,7 +32,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral)))))))))+} + (StringLiteral) + (StringLiteral))))))))+} diff --git a/test/fixtures/go/slice-literals.diff+B.txt b/test/fixtures/go/slice-literals.diff+B.txt index a6e871938..82c07773e 100644 --- a/test/fixtures/go/slice-literals.diff+B.txt +++ b/test/fixtures/go/slice-literals.diff+B.txt @@ -13,8 +13,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -24,8 +23,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -35,7 +33,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral)))))))))+} + (StringLiteral) + (StringLiteral))))))))+} diff --git a/test/fixtures/go/slice-literals.diff-A.txt b/test/fixtures/go/slice-literals.diff-A.txt index ebbf4b437..726e7cef4 100644 --- a/test/fixtures/go/slice-literals.diff-A.txt +++ b/test/fixtures/go/slice-literals.diff-A.txt @@ -22,8 +22,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -33,7 +32,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral)))))))))-} + (StringLiteral) + (StringLiteral))))))))-} diff --git a/test/fixtures/go/slice-literals.diff-B.txt b/test/fixtures/go/slice-literals.diff-B.txt index c95dcc470..491ff651c 100644 --- a/test/fixtures/go/slice-literals.diff-B.txt +++ b/test/fixtures/go/slice-literals.diff-B.txt @@ -13,8 +13,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -24,8 +23,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -35,7 +33,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral)))))))))-} + (StringLiteral) + (StringLiteral))))))))-} diff --git a/test/fixtures/go/slice-literals.diffA-B.txt b/test/fixtures/go/slice-literals.diffA-B.txt index 0e0a784f9..4c3b357c9 100644 --- a/test/fixtures/go/slice-literals.diffA-B.txt +++ b/test/fixtures/go/slice-literals.diffA-B.txt @@ -12,10 +12,8 @@ (Other "composite_literal" (SliceTy (Identifier)) - { (Literal) - ->(Literal - (Element - (StringLiteral))) })))) + (Literal + {+(StringLiteral)+}))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -25,9 +23,8 @@ (SliceTy (Identifier)) (Literal - (Element - { (StringLiteral) - ->(StringLiteral) })))))) + { (StringLiteral) + ->(StringLiteral) }))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -37,9 +34,7 @@ (SliceTy (Identifier)) (Literal - (Element - { (StringLiteral) - ->(StringLiteral) }) - (Element - { (StringLiteral) - ->(StringLiteral) })))))))) + { (StringLiteral) + ->(StringLiteral) } + { (StringLiteral) + ->(StringLiteral) }))))))) diff --git a/test/fixtures/go/slice-literals.diffB-A.txt b/test/fixtures/go/slice-literals.diffB-A.txt index b26ec335b..d72cb1e33 100644 --- a/test/fixtures/go/slice-literals.diffB-A.txt +++ b/test/fixtures/go/slice-literals.diffB-A.txt @@ -12,10 +12,8 @@ (Other "composite_literal" (SliceTy (Identifier)) - { (Literal - (Element - (StringLiteral))) - ->(Literal) })))) + (Literal + {-(StringLiteral)-}))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -25,9 +23,8 @@ (SliceTy (Identifier)) (Literal - (Element - { (StringLiteral) - ->(StringLiteral) })))))) + { (StringLiteral) + ->(StringLiteral) }))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -37,9 +34,7 @@ (SliceTy (Identifier)) (Literal - (Element - { (StringLiteral) - ->(StringLiteral) }) - (Element - { (StringLiteral) - ->(StringLiteral) })))))))) + { (StringLiteral) + ->(StringLiteral) } + { (StringLiteral) + ->(StringLiteral) }))))))) diff --git a/test/fixtures/go/slice-literals.parseA.txt b/test/fixtures/go/slice-literals.parseA.txt index d2e4bcfde..f453cbce6 100644 --- a/test/fixtures/go/slice-literals.parseA.txt +++ b/test/fixtures/go/slice-literals.parseA.txt @@ -22,8 +22,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -33,7 +32,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral))))))))) + (StringLiteral) + (StringLiteral)))))))) diff --git a/test/fixtures/go/slice-literals.parseB.txt b/test/fixtures/go/slice-literals.parseB.txt index debb9a745..a7c100ce1 100644 --- a/test/fixtures/go/slice-literals.parseB.txt +++ b/test/fixtures/go/slice-literals.parseB.txt @@ -13,8 +13,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -24,8 +23,7 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral))))))) + (StringLiteral)))))) (Other "const_declaration" (VarAssignment (Other "identifier_list" @@ -35,7 +33,5 @@ (SliceTy (Identifier)) (Literal - (Element - (StringLiteral)) - (Element - (StringLiteral))))))))) + (StringLiteral) + (StringLiteral)))))))) diff --git a/test/fixtures/toc/javascript/starts-with-newline.js b/test/fixtures/toc/javascript/starts-with-newline.js new file mode 100644 index 000000000..3d4e8ffbd --- /dev/null +++ b/test/fixtures/toc/javascript/starts-with-newline.js @@ -0,0 +1,2 @@ + +//Выберем файлы по нужному пути diff --git a/vendor/effects b/vendor/effects index c47eace16..4ed36cb52 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit c47eace1669cd185286feb336be1a67a28761f5a +Subproject commit 4ed36cb52f60e4d6b692515aa05c493ffcb320bc diff --git a/vendor/gitlib b/vendor/gitlib deleted file mode 160000 index 92125f901..000000000 --- a/vendor/gitlib +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 92125f901c3affd6c625590bbc66891d2a0cff66 diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 432467642..60b991ee8 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 43246764221504a3bb97c7b410fbb92b6e330ec2 +Subproject commit 60b991ee82df7c360f0e1783467ef9b4f6b28467 diff --git a/vendor/text-icu b/vendor/text-icu deleted file mode 160000 index b851ba283..000000000 --- a/vendor/text-icu +++ /dev/null @@ -1 +0,0 @@ -Subproject commit b851ba283cd1bb02f57f9c939219b75bea69afeb