Merge branch 'master' into python-conditional-expressions

.gitignore

@@ -29,3 +29,6 @@ vendor/icu/common/
 vendor/icu/bin/
 vendor/icu/Makefile
 bin/
+
+*.hp
+*.prof

.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

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

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

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

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++

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++

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

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-options:         -Wall -fno-warn-name-shadowing -O -j
-  ghc-prof-options: -fprof-auto
+  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
-  ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j -pgml=script/g++
   default-language:    Haskell2010
   default-extensions:  DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards
 

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

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'
+data ParseMode = ParseStdin | ParsePaths [(FilePath, Maybe Language)]
-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)]
   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

src/Command.hs

@@ -1,98 +1,5 @@
-{-# LANGUAGE DataKinds, GADTs #-}
 module Command
-( Command
+( module Files
--- Constructors
-, readFile
-, readBlobPairsFromHandle
-, readBlobsFromHandle
-, readFilesAtSHA
-, readFilesAtSHAs
--- Evaluation
-, runCommand
 ) where
 
-import qualified Command.Files as Files
+import 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

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.ByteString.Lazy as BL
-import qualified Data.Text.ICU.Detect as Detect
 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 <$> 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
 
 -- | 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
+  input <- BL.hGetContents h
-  case decode (toS input) of
+  case decode input of
     Just d -> pure d
     Nothing -> die ("invalid input on " <> show h <> ", expecting JSON")
 

src/Command/Git.hs

@@ -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

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.

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.
+-- | 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 :: GShow1 f => (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
-  gliftShowList sp sl = showListWith (gliftShowsPrec sp sl 0)
+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

src/Data/Syntax/Assignment.hs

@@ -75,8 +75,8 @@ module Data.Syntax.Assignment
 , Result(..)
 , Error(..)
 , ErrorCause(..)
-, showError
+, printError
-, showExpectation
+, 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
+printError :: Show grammar => Source.Source -> Error grammar -> IO ()
-showError source error@Error{..}
+printError source error@Error{..}
-  = withSGRCode [SetConsoleIntensity BoldIntensity] (showSourcePos Nothing errorPos) . showString ": " . withSGRCode [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation error . showChar '\n'
+  =  do
-  . showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n')
+    withSGRCode [SetConsoleIntensity BoldIntensity] . putStrErr . (showSourcePos Nothing errorPos) . showString ": " $ ""
-  . showString (replicate (succ (Info.column errorPos + lineNumberDigits)) ' ') . withSGRCode [SetColor Foreground Vivid Green] (showChar '^') . showChar '\n'
+    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)) ' ') $ ""
-  . showString (prettyCallStack callStack)
+    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
+        putStrErr = hPutStr stderr
-        withSGRCode code s = showSGRCode code . s . showSGRCode []
+
+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

src/GitmonClient.hs

@@ -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
-

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.

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

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 -> Cofree [] (Record (NodeType ': Location))
-cmarkParser source = pure . toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source)
+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

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
+        traverse_ (printError source) errors
-        unless (Prologue.null errors) $
+        unless (Prologue.null errors) $ do
-          putStrLn (withSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] (shows (Prologue.length errors) . showChar ' ' . showString (if Prologue.length errors == 1 then "error" else "errors")) $ "")
+          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)))

src/RWS.hs

@@ -12,14 +12,13 @@ module RWS (
   , defaultD
   ) where
 
-import Prologue
+import Prologue hiding (State, evalState, runState)
-import Control.Monad.Effect as Eff
+import Control.Monad.State.Strict
-import Control.Monad.Effect.Internal as I
 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.
+    termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term.
-  , feature   :: FeatureVector -- ^ Feature vector
+  , 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))
+    -> [Term f (Record fields)]
-    -> t (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
+rws _            _          as [] = This <$> as
-  sesDiffs <- ses'
+rws _            _          [] bs = That <$> bs
-  (featureAs, featureBs, mappedDiffs, allDiffs) <- genFeaturizedTermsAndDiffs' sesDiffs
+rws _            canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]
-  (diffs, remaining) <- findNearestNeighoursToDiff' allDiffs featureAs featureBs
+rws editDistance canCompare as bs =
-  diffs' <- deleteRemaining' diffs remaining
+  let sesDiffs = ses (equalTerms canCompare) as bs
-  rwsDiffs <- insertMapped' mappedDiffs diffs'
+      (featureAs, featureBs, mappedDiffs, allDiffs) = genFeaturizedTermsAndDiffs sesDiffs
-  pure (fmap snd rwsDiffs)
+      (diffs, remaining) = findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs
-
+      diffs' = deleteRemaining diffs remaining
-data RWS f fields result where
+      rwsDiffs = insertMapped mappedDiffs diffs'
-  SES :: RWS f fields (RWSEditScript f fields)
+  in fmap snd rwsDiffs
-
-  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]
 
 -- | 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
+  Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing
-    (_, unA, unB) <- get
-    put (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
+                           -> ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)])
-                                (Int, Int)
+genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d)
-                                ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)])
+  where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of
-genFeaturizedTermsAndDiffs sesDiffs = case sesDiffs of
+          This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs)
-  [] -> pure ([], [], [], [])
+          That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (Term (featurize counterB term) : allDiffs)
-  (diff : diffs) -> do
+          These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs)
-    (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)
 
-featurize :: (HasField fields (Maybe FeatureVector), Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields
+data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)]
-featurize index term = UnmappedTerm index (let Just v = getField (extract term) in v) (eraseFeatureVector term)
 
-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)
+ where collect ((gram :. rest) :< functor) = cofree ((foldl' addSubtermVector (unitVector d (hash gram)) functor :. rest) :< functor)
-       addSubtermVector :: Functor f => Maybe FeatureVector -> Term f (Record (Maybe FeatureVector ': fields)) -> Maybe FeatureVector
+       addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector
-       addSubtermVector v term = addVectors <$> v <*> rhead (extract term)
+       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) components))
-    invMagnitude = 1 / sqrtDouble (sum (fmap (** 2) uniform))
+    components = evalRand (sequenceA (replicate d (liftRand randomDouble))) (pureMT (fromIntegral hash))
-    components = sequenceA (replicate d (liftRand randomDouble))
 
 -- | Test the comparability of two root 'Term's in O(1).
 canCompareTerms :: ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool

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.

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
+-- | Construct a 'JSONSummary' from a node annotation and a change type label.
-renderToC blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
+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

src/SES/Myers.hs

@@ -1,415 +1,71 @@
-{-# LANGUAGE GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
 module SES.Myers
-( MyersF(..)
+( EditScript
-, EditScript
-, Step(..)
-, Myers
-, EditGraph(..)
-, Distance(..)
-, Diagonal(..)
-, Endpoint(..)
 , ses
-, runMyers
-, runMyersSteps
-, lcs
-, editDistance
-, MyersState(..)
 ) where
 
-import Control.Exception
+import Data.Array ((!))
-import Control.Monad.Free.Freer
 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 (error)
-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 ()
-
 
 -- | 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 Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
-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) }
   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 :: (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)
+ses eq as' bs'
-
+  | null bs = This <$> toList as
-
+  | null as = That <$> toList bs
--- Evaluation
+  | 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'))
--- | Fully evaluate an operation in Myers’ algorithm given a comparator function and an edit graph.
+        (!n, !m) = (length as', length bs')
-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)
+        -- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
-  where go :: forall c. Myers a b c -> Prologue.State (MyersState a b) c
+        searchUpToD !d !v =
-        go = iterFreerA algebra
+          let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
-        algebra :: forall c x. Step a b x -> (x -> Prologue.State (MyersState a b) c) -> Prologue.State (MyersState a b) c
+          case find isComplete endpoints of
-        algebra step cont = case step of
+            Just (Endpoint _ _ script) -> script
-          M m -> go (decompose' m) >>= cont
+            _ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
-          S Get -> get >>= cont
+          where isComplete (Endpoint x y _) = x >= n && y >= m
-          S (Put s) -> put s >>= cont
+
-        decompose' :: forall c. MyersF a b c -> Myers a b c
+                -- 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).
-        decompose' = decompose eq graph
+                searchAlongK !k
-
+                  | k == -d = moveDownFrom (v ! succ k)
--- | Fully evaluate an operation in Myers’ algorithm given a comparator function and an edit graph, returning a list of states and next steps.
+                  | k ==  d = moveRightFrom (v ! pred k)
-runMyersSteps :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> Myers a b c -> [(MyersState a b, Myers a b c)]
+                  | k == -m = moveDownFrom (v ! succ k)
-runMyersSteps eq graph = go (emptyStateForGraph graph)
+                  | k ==  n = moveRightFrom (v ! pred k)
-  where go state step = let ?callStack = popCallStack callStack in prefix state step $ case runMyersStep eq graph state step of
+                  | otherwise =
-          Left result -> [ (state, return result) ]
+                    let left = v ! pred k
-          Right next -> uncurry go next
+                        up   = v ! succ k in
-        prefix state step = case step of
+                    if x left < x up then
-          Then (M _) _ -> ((state, step) :)
+                      moveDownFrom up
-          _ -> identity
+                    else
-
+                      moveRightFrom left
--- | 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)
+        -- | Move downward from a given vertex, inserting the element for the corresponding row.
-runMyersStep eq graph state step = let ?callStack = popCallStack callStack in case step of
+        moveDownFrom  (Endpoint x y script) = Endpoint       x (succ y) $ maybe script ((: script) . That) (bs !? y)
-  Return a -> Left a
+        {-# INLINE moveDownFrom #-}
-  Then step cont -> case step of
+
-    M myers -> Right (state, decompose eq graph myers >>= cont)
+        -- | 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)
-    S Get -> Right (state, cont state)
+        {-# INLINE moveRightFrom #-}
-    S (Put state') -> Right (state', cont ())
+
-
+        -- | Slide down any diagonal edges from a given vertex.
-
+        slideFrom (Endpoint x y script)
--- | Decompose an operation in Myers’ algorithm into its continuation.
+          | Just a <- as !? x
---
+          , Just b <- bs !? y
---   Dispatches to the per-operation run… functions which implement the meat of the algorithm.
+          , a `eq` b  = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
-decompose :: HasCallStack => (a -> b -> Bool) -> EditGraph a b -> MyersF a b c -> Myers a b c
+          | otherwise =            Endpoint       x        y               script
-decompose eq graph myers = let ?callStack = popCallStack callStack in case myers of
+
-  SES -> runSES graph
+
-  LCS -> runLCS graph
+(!?) :: Ix i => Array.Array i a -> i -> Maybe a
-  EditDistance -> runEditDistance graph
+(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
-  SearchUpToD d -> runSearchUpToD graph d
+         | otherwise = Nothing
-  SearchAlongK d k -> runSearchAlongK graph d k
+{-# INLINE (!?) #-}
-  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)

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.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 (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 (renderToCDiff blobs)
-  (ToCDiffRenderer, _) -> run (\ source -> parse syntaxParser source >>= decorate (syntaxDeclarationAlgebra source)) diffTerms (renderToC 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)

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
+  Arguments{..} <- customExecParser (prefs showHelpOnEmpty) arguments
-  alternates <- findAlternates
-  Arguments{..} <- customExecParser (prefs showHelpOnEmpty) (arguments gitDir alternates)
   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 :: ParserInfo Arguments
-arguments gitDir alternates = info (version <*> helper <*> argumentsParser) description
+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."
+    description = fullDesc <> header "semantic -- Parse and diff semantically"
-                           <> 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 (DiffArguments PatchDiffRenderer) (DiffArguments PatchDiffRenderer) (long "patch" <> help "Output a patch(1)-compatible diff (default)")
-           <|> flag' jsonDiff (long "json" <> help "Output a json diff")
+           <|> flag' (DiffArguments JSONDiffRenderer) (long "json" <> help "Output a json diff")
-           <|> flag' sExpressionDiff (long "sexpression" <> help "Output an s-expression diff tree")
+           <|> flag' (DiffArguments SExpressionDiffRenderer) (long "sexpression" <> help "Output an s-expression diff tree")
-           <|> flag' tocDiff (long "toc" <> help "Output a table of contents for a diff") )
+           <|> 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
+            <|> pure DiffStdin ))
-               <$> 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 )
 
-    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 (ParseArguments SExpressionTermRenderer) (ParseArguments SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
-           <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees") )
+           <|> 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
+            <|> pure ParseStdin ))
-               <$> 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
 
     filePathReader = eitherReader parseFilePath
     parseFilePath arg = case splitWhen (== ':') arg of

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)

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<String>) {\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
+  where blobsFromFilePath path = 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
           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)

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

test/GitmonClientSpec.hs

@@ -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))

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" $
+  describe "runDiff" $
-    \ DiffFixture{..} -> do
+    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
+        sExpressionParseTreeOutput = "(Program\n  (Binary\n    (Identifier)\n    (Other \"and\")\n    (Identifier)))\n"
-  { arguments :: ParseArguments
+        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"
-  , expected :: ByteString
+        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"
-  } deriving (Show)
+        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"
-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"
 
 
 data DiffFixture = DiffFixture
@@ -59,29 +51,20 @@ data DiffFixture = DiffFixture
   , expected :: ByteString
   } deriving (Show)
 
-instance Listable DiffFixture where
+diffFixtures :: [(DiffArguments, ByteString)]
-  tiers = cons0 (DiffFixture (patchDiff pathMode "" []) patchOutput)
+diffFixtures =
-       \/ cons0 (DiffFixture (jsonDiff pathMode "" []) jsonOutput)
+  [ (DiffArguments PatchDiffRenderer pathMode, patchOutput)
-       \/ cons0 (DiffFixture (sExpressionDiff pathMode "" []) sExpressionOutput)
+  , (DiffArguments JSONDiffRenderer pathMode, jsonOutput)
-       \/ cons0 (DiffFixture (tocDiff pathMode "" []) tocOutput)
+  , (DiffArguments SExpressionDiffRenderer pathMode, sExpressionOutput)
-       \/ cons0 (DiffFixture (patchDiff commitMode repo []) patchOutput')
+  , (DiffArguments ToCDiffRenderer pathMode, tocOutput)
-       \/ cons0 (DiffFixture (jsonDiff commitMode repo []) jsonOutput')
+  ]
-       \/ cons0 (DiffFixture (sExpressionDiff commitMode repo []) sExpressionOutput')
+  where pathMode = DiffPaths ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)
-       \/ cons0 (DiffFixture (tocDiff commitMode repo []) tocOutput')
 
-    where
+        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"
-      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"
+        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"
-      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"
+        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"
-      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"
 
 repo :: FilePath
 repo = "test/fixtures/git/examples/all-languages.git"

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

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

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)

test/fixtures/git/examples/all-languages.git/HEAD

@@ -1 +0,0 @@
-ref: refs/heads/master

test/fixtures/git/examples/all-languages.git/config

@@ -1,6 +0,0 @@
-[core]
-	repositoryformatversion = 0
-	filemode = true
-	bare = true
-	ignorecase = true
-	precomposeunicode = true

test/fixtures/git/examples/all-languages.git/hooks/post-receive

@@ -1,5 +0,0 @@
-#!/bin/sh
-#
-# Aggressively pack example repos in fixtures
-
-exec git gc --agressive

test/fixtures/git/examples/all-languages.git/info/refs

@@ -1 +0,0 @@
-2e4144eb8c44f007463ec34cb66353f0041161fe	refs/heads/master

test/fixtures/git/examples/all-languages.git/objects/info/packs

@@ -1,2 +0,0 @@
-P pack-5780c6ea9558e3f68939b63e4f2365eb390e658d.pack
-

test/fixtures/git/examples/all-languages.git/packed-refs

@@ -1,2 +0,0 @@
-# pack-refs with: peeled fully-peeled 
-2e4144eb8c44f007463ec34cb66353f0041161fe refs/heads/master

test/fixtures/go/array-with-implicit-length.diff+A.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))+}
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))+}

test/fixtures/go/array-with-implicit-length.diff+B.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))+}
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))+}

test/fixtures/go/array-with-implicit-length.diff-A.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))-}
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))-}

test/fixtures/go/array-with-implicit-length.diff-B.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))-}
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))-}

test/fixtures/go/array-with-implicit-length.diffA-B.txt

@@ -12,12 +12,9 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+              { (NumberLiteral)
-            { (NumberLiteral)
+              ->(NumberLiteral) }
-            ->(NumberLiteral) })
+              { (NumberLiteral)
-            (Element
+              ->(NumberLiteral) }
-            { (NumberLiteral)
+              {+(NumberLiteral)+}
-            ->(NumberLiteral) })
+              {-(NumberLiteral)-}))))))
-            (Element
-            { (NumberLiteral)
-            ->(NumberLiteral) })))))))

test/fixtures/go/array-with-implicit-length.diffB-A.txt

@@ -12,12 +12,9 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+              { (NumberLiteral)
-            { (NumberLiteral)
+              ->(NumberLiteral) }
-            ->(NumberLiteral) })
+              { (NumberLiteral)
-            (Element
+              ->(NumberLiteral) }
-            { (NumberLiteral)
+              {+(NumberLiteral)+}
-            ->(NumberLiteral) })
+              {-(NumberLiteral)-}))))))
-            (Element
-            { (NumberLiteral)
-            ->(NumberLiteral) })))))))

test/fixtures/go/array-with-implicit-length.parseA.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))

test/fixtures/go/array-with-implicit-length.parseB.txt

@@ -12,9 +12,6 @@
           (Other "composite_literal"
             (ArrayTy
               (Identifier))
-            (Element
+            (NumberLiteral)
-              (NumberLiteral))
+            (NumberLiteral)
-            (Element
+            (NumberLiteral)))))))
-              (NumberLiteral))
-            (Element
-              (NumberLiteral))))))))

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)
-                (StringLiteral))
+              (StringLiteral))))))))+}
-              (Element
-                (StringLiteral)))))))))+}

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)
-                (StringLiteral))
+              (StringLiteral))))))))+}
-              (Element
-                (StringLiteral)))))))))+}

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)
-                (StringLiteral))
+              (StringLiteral))))))))-}
-              (Element
-                (StringLiteral)))))))))-}

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)
-                (StringLiteral))
+              (StringLiteral))))))))-}
-              (Element
-                (StringLiteral)))))))))-}

test/fixtures/go/slice-literals.diffA-B.txt

@@ -12,10 +12,8 @@
           (Other "composite_literal"
             (SliceTy
               (Identifier))
-          { (Literal)
+          (Literal
-          ->(Literal
+            {+(StringLiteral)+})))))
-              (Element
-                (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)
+            ->(StringLiteral) }
-              ->(StringLiteral) })
+            { (StringLiteral)
-              (Element
+            ->(StringLiteral) })))))))
-              { (StringLiteral)
-              ->(StringLiteral) }))))))))

test/fixtures/go/slice-literals.diffB-A.txt

@@ -12,10 +12,8 @@
           (Other "composite_literal"
             (SliceTy
               (Identifier))
-          { (Literal
+          (Literal
-              (Element
+            {-(StringLiteral)-})))))
-                (StringLiteral)))
-          ->(Literal) }))))
     (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)
+            ->(StringLiteral) }
-              ->(StringLiteral) })
+            { (StringLiteral)
-              (Element
+            ->(StringLiteral) })))))))
-              { (StringLiteral)
-              ->(StringLiteral) }))))))))

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)
-                (StringLiteral))
+              (StringLiteral))))))))
-              (Element
-                (StringLiteral)))))))))

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)
-                (StringLiteral))
+              (StringLiteral))))))))
-              (Element
-                (StringLiteral)))))))))

test/fixtures/toc/javascript/starts-with-newline.js

@@ -0,0 +1,2 @@
+
+//Выберем файлы по нужному пути

vendor/effects

@@ -1 +1 @@
-Subproject commit c47eace1669cd185286feb336be1a67a28761f5a
+Subproject commit 4ed36cb52f60e4d6b692515aa05c493ffcb320bc

vendor/gitlib

@@ -1 +0,0 @@
-Subproject commit 92125f901c3affd6c625590bbc66891d2a0cff66

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 43246764221504a3bb97c7b410fbb92b6e330ec2
+Subproject commit 60b991ee82df7c360f0e1783467ef9b4f6b28467

vendor/text-icu

@@ -1 +0,0 @@
-Subproject commit b851ba283cd1bb02f57f9c939219b75bea69afeb