Merge branch 'look-up-its-a-core' into compile-string-literals

.hlint.yaml

@@ -34,6 +34,10 @@
 # Change the severity of hints we don’t want to fail CI for
 - suggest: {name: Eta reduce}
 
+# While I think DerivingStrategies is good, it's too noisy to suggest by default
+- ignore:
+    name: Use DerivingStrategies
+
 # Ignore eta reduce in the assignment modules
 - ignore:
     name: Eta reduce
@@ -45,8 +49,29 @@
 
 - ignore: {name: Use ., within: [Analysis.Abstract.Graph.graphingModules, Semantic.Distribute]}
 
-- ignore: {name: Reduce duplication, within: [Semantic.Util, Semantic.UtilDisabled]}
-- ignore: {name: Use newtype instead of data, within: [Semantic.Api.V1.CodeAnalysisPB]}
+- ignore:
+    within:
+      - Proto.Semantic
+      - Proto.Semantic_Fields
+      - Proto.Semantic_JSON
+
+- ignore:
+    name: Reduce duplication
+    within:
+      - Semantic.Util
+
+# hlint has issues with QuantifiedConstraints (see https://github.com/ndmitchell/hlint/issues/759)
+# Once the above is fixed, we can drop this error.
+
+- ignore: { name: Parse error }
+
+# hlint is too paranoid about NonEmpty functions (https://github.com/ndmitchell/hlint/issues/787)
+
+- ignore:
+    name: Avoid restricted function
+    within:
+      - Language.Python.Syntax
+      - Data.Syntax.Expression
 
 # Our customized warnings
 

.travis.yml

@@ -24,9 +24,14 @@ matrix:
 
 before_install:
 - mkdir -p $HOME/.local/bin
+- curl -L -o /tmp/hlint.tar.gz "https://github.com/ndmitchell/hlint/releases/download/v2.2.3/hlint-2.2.3-x86_64-linux.tar.gz"
+- tar -xf /tmp/hlint.tar.gz -C /tmp
+- cp /tmp/hlint-2.2.3/hlint $HOME/.local/bin
+- cp -r /tmp/hlint-2.2.3/data $HOME/.local/bin
 - "PATH=/opt/ghc/bin:$HOME/local/bin:$PATH"
 - ghc --version
 - cabal --version
+- hlint --version
 
 install:
 - cabal v2-update -v
@@ -34,6 +39,7 @@ install:
 - cabal v2-build --only-dependencies
 
 script:
+- hlint src semantic-python
 - cabal v2-build
 - cabal v2-run semantic:test
 - cabal v2-run semantic-core:test

semantic-core/src/Core/Core.hs

@@ -26,6 +26,7 @@ module Core.Core
 , load
 , record
 , (...)
+, (.?)
 , (.=)
 , Ann(..)
 , ann
@@ -75,6 +76,8 @@ data Core f a
   | Record [(Name, f a)]
   -- | Projection from a record.
   | f a :. Name
+  -- | Projection of a record, with failure.
+  | f a :? Name
   -- | Assignment of a value to the reference returned by the lhs.
   | f a := f a
   deriving (Foldable, Functor, Generic1, Traversable)
@@ -105,6 +108,7 @@ instance RightModule Core where
   Load b     >>=* f = Load (b >>= f)
   Record fs  >>=* f = Record (map (fmap (>>= f)) fs)
   (a :. b)   >>=* f = (a >>= f) :. b
+  (a :? b)   >>=* f = (a >>= f) :. b
   (a := b)   >>=* f = (a >>= f) := (b >>= f)
 
 
@@ -209,6 +213,11 @@ a ... b = send (a :. b)
 
 infixl 9 ...
 
+(.?) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a
+a .? b = send (a :? b)
+
+infixl 9 .?
+
 (.=) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a
 a .= b = send (a := b)
 

semantic-core/src/Core/Eval.hs

@@ -20,7 +20,7 @@ import Control.Monad ((>=>))
 import Core.Core as Core
 import Core.Name
 import Data.Functor
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import GHC.Stack
 import Prelude hiding (fail)
 import Source.Span
@@ -68,6 +68,11 @@ eval Analysis{..} eval = \case
     a :. b -> do
       a' <- ref a
       a' ... b >>= maybe (freeVariable (show b)) (deref' b)
+    a :? b -> do
+      a' <- ref a
+      mFound <- a' ... b
+      bool (isJust mFound)
+
     a := b -> do
       b' <- eval b
       addr <- ref a

semantic-core/src/Core/Parser.hs

@@ -11,12 +11,12 @@ module Core.Parser
 -- Consult @doc/grammar.md@ for an EBNF grammar.
 
 import           Control.Applicative
+import           Control.Category ((>>>))
 import           Control.Effect.Carrier
 import           Core.Core ((:<-) (..), Core)
 import qualified Core.Core as Core
 import           Core.Name
 import qualified Data.Char as Char
-import           Data.Foldable (foldl')
 import           Data.String
 import qualified Text.Parser.Token as Token
 import qualified Text.Parser.Token.Highlight as Highlight
@@ -61,7 +61,12 @@ application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t
 application = projection `chainl1` (pure (Core.$$))
 
 projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
-projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name)
+projection = let a <$$> b = flip a <$> b in do
+  head <- atom
+  res <- many (choice [ (Core..?)  <$$> (symbol ".?" *> identifier)
+                      , (Core....) <$$> (dot *> identifier)
+                      ])
+  pure (foldr (>>>) id res head)
 
 atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name)
 atom = choice

semantic-core/src/Core/Pretty.hs

@@ -74,6 +74,7 @@ prettyCore style = unPrec . go . fmap name
 
             Load p -> prec 3 (keyword "load" <+> withPrec 9 (go p))
             item :. body -> prec 9 (withPrec 9 (go item) <> symbol "." <> name body)
+            item :? body -> prec 9 (withPrec 9 (go item) <> symbol ".?" <> name body)
 
             lhs := rhs -> prec 3 . group . nest 2 $ vsep
               [ withPrec 4 (go lhs)

semantic-core/test/Generators.hs

@@ -70,5 +70,6 @@ expr = Gen.recursive Gen.choice atoms
   , Gen.subterm expr Core.load
   , record expr
   , Gen.subtermM expr (\ x -> (x Core....) . namedValue <$> name)
+  , Gen.subtermM expr (\ x -> (x Core..?)  . namedValue <$> name)
   , Gen.subterm2 expr expr (Core..=)
   ]

semantic-python/src/Prelude.score

@@ -1,14 +1,20 @@
 {
-  type <- \name -> \bases -> \dict ->
-    #record { __name: name, __bases: bases, __dict: dict };
+  type <- \name -> \super -> \slots ->
+    #record { __name: name, __super: super, __slots: slots };
 
   instance <- \class -> \prim -> \slots ->
     #record { __class: class, __prim: prim, __slots: slots };
 
-  object <- type "object" #unit #record{};
+  object <- type "object" type #record{};
 
   str <- type "str" object #record { };
-  str.__class.__new__ = (\contents -> instance str contents #record{});
+  str.__new__ = (\contents -> instance str contents #record{});
 
   #record { type: type, object: object, str: str }
+
+  getitem <- rec getitem = \item -> \attr ->
+    if item.slots.?attr then item.slots.attr else #unit;
+
+  #record { type: type, object: object, getitem: getitem }
+
 }

semantic-python/test/Directive.hs

@@ -7,8 +7,8 @@ module Directive ( Directive (..)
 import           Control.Applicative
 import           Control.Monad
 import           Core.Core (Core)
-import qualified Core.Parser as Core.Parser
-import qualified Core.Pretty as Core.Pretty
+import qualified Core.Parser
+import qualified Core.Pretty
 import           Core.Name (Name)
 import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as ByteString

semantic-python/test/Instances.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, LambdaCase, StandaloneDeriving, FlexibleInstances, NamedFieldPuns, OverloadedStrings, QuantifiedConstraints, TypeOperators, UndecidableInstances, TypeApplications #-}
+{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, NamedFieldPuns, OverloadedStrings, QuantifiedConstraints, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Instances () where

semantic.cabal

@@ -67,9 +67,7 @@ common dependencies
                      , semantic-source ^>= 0.0
                      , semilattices ^>= 0.0.0.3
                      , streaming ^>= 0.2.2.0
-                     , streaming-bytestring ^>= 0.1.6
                      , text ^>= 1.2.3.1
-                     , these >= 0.7 && <1
                      , unix ^>= 2.7.2.2
                      , lingo ^>= 0.3.0.0
 
@@ -148,9 +146,9 @@ library
                      , Data.Blob.IO
                      , Data.Diff
                      , Data.Duration
+                     , Data.Edit
                      , Data.Error
                      , Data.Flag
-                     , Data.Functor.Both
                      , Data.Functor.Classes.Generic
                      , Data.Graph
                      , Data.Graph.ControlFlowVertex
@@ -160,7 +158,6 @@ library
                      , Data.JSON.Fields
                      , Data.Language
                      , Data.Map.Monoidal
-                     , Data.Patch
                      , Data.Project
                      , Data.Quieterm
                      , Data.Semigroup.App
@@ -229,7 +226,6 @@ library
                      , Semantic.Config
                      , Semantic.Distribute
                      , Semantic.Env
-                     , Semantic.Git
                      , Semantic.Graph
                      , Semantic.IO
                      , Semantic.Resolution
@@ -288,8 +284,6 @@ library
                      , semantic-tags ^>= 0
                      , semigroupoids ^>= 5.3.2
                      , split ^>= 0.2.3.3
-                     , streaming-attoparsec ^>= 1.0.0.1
-                     , streaming-process ^>= 0.1
                      , stm-chans ^>= 3.0.0.4
                      , template-haskell ^>= 2.14
                      , time ^>= 1.8.0.2
@@ -362,7 +356,6 @@ test-suite test
                      , hspec >= 2.6 && <3
                      , hspec-core >= 2.6 && <3
                      , hspec-expectations ^>= 0.8.2
-                     , shelly >= 1.5 && <2
                      , tasty ^>= 1.2.3
                      , tasty-golden ^>= 2.3.2
                      , tasty-hedgehog ^>= 1.0.0.1
@@ -384,7 +377,7 @@ test-suite parse-examples
                      , foldl ^>= 1.4.5
                      , resourcet ^>= 1.2
                      , streaming
-                     , streaming-bytestring
+                     , streaming-bytestring ^>= 0.1.6
                      , tasty
                      , tasty-hunit
 

src/Control/Abstract/Value.hs

@@ -292,15 +292,9 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m)
              -> m value
 liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure)
 
-data NumericFunction = NumericFunction (forall a . Num a => a -> a)
+newtype NumericFunction = NumericFunction { runNumericFunction :: forall a . Num a => a -> a }
 
-runNumericFunction :: Num a => NumericFunction -> a -> a
-runNumericFunction (NumericFunction f) a = f a
-
-data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber)
-
-runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber
-runNumeric2Function (Numeric2Function f) a b = f a b
+newtype Numeric2Function = Numeric2Function { runNumeric2Function :: forall a b. Number a -> Number b -> SomeNumber }
 
 data Numeric value (m :: * -> *) k
   = Integer Integer (value -> m k)
@@ -347,15 +341,9 @@ unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m)
                -> m value
 unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure)
 
-data BitwiseFunction = BitwiseFunction (forall a . Bits a => a -> a)
+newtype BitwiseFunction = BitwiseFunction { runBitwiseFunction :: forall a . Bits a => a -> a }
 
-runBitwiseFunction :: Bits a => BitwiseFunction -> a -> a
-runBitwiseFunction (BitwiseFunction f) a = f a
-
-data Bitwise2Function = Bitwise2Function (forall a . (Integral a, Bits a) => a -> a -> a)
-
-runBitwise2Function :: (Integral a, Bits a) => Bitwise2Function -> a -> a -> a
-runBitwise2Function (Bitwise2Function f) a b = f a b
+newtype Bitwise2Function = Bitwise2Function { runBitwise2Function :: forall a . (Integral a, Bits a) => a -> a -> a }
 
 data Bitwise value (m :: * -> *) k
   = CastToInteger value (value -> m k)

src/Control/Carrier/Parse/Simple.hs

@@ -63,7 +63,7 @@ runParser timeout blob@Blob{..} parser = case parser of
     let term = cmarkParser blobSource
     in length term `seq` pure term
 
-data ParseFailure = ParseFailure String
+newtype ParseFailure = ParseFailure String
   deriving (Show, Typeable)
 
 instance Exception ParseFailure

src/Control/Effect/Parse.hs

@@ -12,9 +12,9 @@ import Control.Effect.Error
 import Control.Exception (SomeException)
 import Data.Bitraversable
 import Data.Blob
+import Data.Edit
 import Data.Language
 import qualified Data.Map as Map
-import Data.These
 import Parsing.Parser
 
 data Parse m k
@@ -51,11 +51,11 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of
 -- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair.
 parsePairWith
   :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig)
-  => Map.Map Language (SomeParser c ann)                                      -- ^ The set of parsers to select from.
-  -> (forall term . c term => These (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
-  -> BlobPair                                                                 -- ^ The blob pair to parse.
+  => Map.Map Language (SomeParser c ann)                                     -- ^ The set of parsers to select from.
+  -> (forall term . c term => Edit (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@.
+  -> BlobPair                                                                -- ^ The blob pair to parse.
   -> m a
 parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of
-  Just (SomeParser parser) -> bitraverse (p parser) (p parser) (getBlobPair blobPair) >>= with
+  Just (SomeParser parser) -> bitraverse (p parser) (p parser) blobPair >>= with
   _                        -> noLanguageForBlob (pathForBlobPair blobPair)
   where p parser blob = (,) blob <$> parse parser blob

src/Data/Blob.hs

@@ -13,10 +13,7 @@ module Data.Blob
 , nullBlob
 , sourceBlob
 , noLanguageForBlob
-, BlobPair(..)
-, pattern Diffing
-, pattern Inserting
-, pattern Deleting
+, BlobPair
 , maybeBlobPair
 , decodeBlobPairs
 , languageForBlobPair
@@ -30,6 +27,7 @@ import Prologue
 import           Control.Effect.Error
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
+import           Data.Edit
 import           Data.JSON.Fields
 import           Data.Language
 import           Source.Source (Source)
@@ -101,62 +99,33 @@ noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPa
 
 -- | Represents a blobs suitable for diffing which can be either a blob to
 -- delete, a blob to insert, or a pair of blobs to diff.
-newtype BlobPair = BlobPair { getBlobPair :: These Blob Blob }
-  deriving (Eq, Show)
+type BlobPair = Edit Blob Blob
 
 instance FromJSON BlobPair where
-  parseJSON = withObject "BlobPair" $ \o -> do
-    before <- o .:? "before"
-    after <- o .:? "after"
-    case (before, after) of
-      (Just b, Just a)  -> pure $ Diffing b a
-      (Just b, Nothing) -> pure $ Deleting b
-      (Nothing, Just a) -> pure $ Inserting a
-      _                 -> Prelude.fail "Expected object with 'before' and/or 'after' keys only"
-
-pattern Diffing :: Blob -> Blob -> BlobPair
-pattern Diffing a b = BlobPair (These a b)
-
-pattern Inserting :: Blob -> BlobPair
-pattern Inserting a = BlobPair (That a)
-
-pattern Deleting :: Blob -> BlobPair
-pattern Deleting b = BlobPair (This b)
-
-{-# COMPLETE Diffing, Inserting, Deleting #-}
+  parseJSON = withObject "BlobPair" $ \o ->
+    fromMaybes <$> (o .:? "before") <*> (o .:? "after")
+    >>= maybeM (Prelude.fail "Expected object with 'before' and/or 'after' keys only")
 
 maybeBlobPair :: MonadFail m => Maybe Blob -> Maybe Blob -> m BlobPair
-maybeBlobPair a b = case (a, b) of
-  (Just a, Nothing) -> pure (Deleting a)
-  (Nothing, Just b) -> pure (Inserting b)
-  (Just a, Just b)  -> pure (Diffing a b)
-  _                 -> Prologue.fail "expected file pair with content on at least one side"
+maybeBlobPair a b = maybeM (Prologue.fail "expected file pair with content on at least one side") (fromMaybes a b)
 
 languageForBlobPair :: BlobPair -> Language
-languageForBlobPair (Deleting b)  = blobLanguage b
-languageForBlobPair (Inserting b) = blobLanguage b
-languageForBlobPair (Diffing a b)
-  | blobLanguage a == Unknown || blobLanguage b == Unknown
-    = Unknown
-  | otherwise
-    = blobLanguage b
+languageForBlobPair = mergeEdit combine . bimap blobLanguage blobLanguage where
+  combine a b
+    | a == Unknown || b == Unknown = Unknown
+    | otherwise                    = b
 
 pathForBlobPair :: BlobPair -> FilePath
-pathForBlobPair x = blobPath $ case x of
-  (Inserting b) -> b
-  (Deleting b)  -> b
-  (Diffing _ b) -> b
+pathForBlobPair = blobPath . mergeEdit (const id)
 
 languageTagForBlobPair :: BlobPair -> [(String, String)]
 languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)
   where showLanguage = pure . (,) "language" . show
 
 pathKeyForBlobPair :: BlobPair -> FilePath
-pathKeyForBlobPair blobs = case bimap blobPath blobPath (getBlobPair blobs) of
-   This before -> before
-   That after -> after
-   These before after | before == after -> after
-                      | otherwise -> before <> " -> " <> after
+pathKeyForBlobPair = mergeEdit combine . bimap blobPath blobPath where
+   combine before after | before == after = after
+                        | otherwise       = before <> " -> " <> after
 
 instance ToJSONFields Blob where
   toJSONFields p = [ "path" .= blobPath p, "language" .= blobLanguage p]

src/Data/Blob/IO.hs

@@ -6,8 +6,6 @@ module Data.Blob.IO
   ( readBlobFromFile
   , readBlobFromFile'
   , readBlobsFromDir
-  , readBlobsFromGitRepo
-  , readBlobsFromGitRepoPath
   , readFilePair
   ) where
 
@@ -17,12 +15,9 @@ import qualified Control.Concurrent.Async as Async
 import           Data.Blob
 import qualified Data.ByteString as B
 import           Data.Language
-import           Data.Text.Encoding (decodeUtf8)
-import qualified Semantic.Git as Git
 import           Semantic.IO
 import qualified Source.Source as Source
 import qualified System.Path as Path
-import qualified System.Path.PartClass as Part
 
 -- | Read a utf8-encoded file to a 'Blob'.
 readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob)
@@ -42,28 +37,6 @@ readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob]
 readBlobsFromDir path = liftIO . fmap catMaybes $
   findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForTypedPath)
 
-readBlobsFromGitRepoPath :: (Part.AbsRel ar, MonadIO m) => Path.Dir ar -> Git.OID -> [Path.RelFile] -> [Path.RelFile] -> m [Blob]
-readBlobsFromGitRepoPath path oid excludePaths includePaths
-  = readBlobsFromGitRepo (Path.toString path) oid (fmap Path.toString excludePaths) (fmap Path.toString includePaths)
-
--- | Read all blobs from a git repo. Prefer readBlobsFromGitRepoPath, which is typed.
-readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> [FilePath] -> m [Blob]
-readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybes $
-  Git.lsTree path oid >>= Async.mapConcurrently (blobFromTreeEntry path)
-  where
-    -- Only read tree entries that are normal mode, non-minified blobs in a language we can parse.
-    blobFromTreeEntry :: FilePath -> Git.TreeEntry -> IO (Maybe Blob)
-    blobFromTreeEntry gitDir (Git.TreeEntry Git.NormalMode Git.BlobObject oid path)
-      | lang <- languageForFilePath path
-      , lang `elem` codeNavLanguages
-      , not (pathIsMinified path)
-      , path `notElem` excludePaths
-      , null includePaths || path `elem` includePaths
-      = Just . sourceBlob' path lang oid <$> Git.catFile gitDir oid
-    blobFromTreeEntry _ _ = pure Nothing
-
-    sourceBlob' filepath language (Git.OID oid) source = makeBlob source filepath language (decodeUtf8 oid)
-
 readFilePair :: MonadIO m => File -> File -> m BlobPair
 readFilePair a b = do
   before <- readBlobFromFile a

src/Data/Diff.hs

@@ -1,9 +1,9 @@
-{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-}
+{-# LANGUAGE DataKinds, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-}
 module Data.Diff
 ( Diff(..)
 , DiffF(..)
-, replacing
-, replaceF
+, comparing
+, compareF
 , inserting
 , insertF
 , deleting
@@ -18,10 +18,10 @@ import Data.Aeson
 import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
+import Data.Edit
 import Data.Functor.Classes
 import Data.Functor.Foldable
 import Data.JSON.Fields
-import Data.Patch
 import Data.Term
 import Text.Show
 
@@ -30,19 +30,19 @@ newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff sy
 
 -- | A single entry within a recursive 'Diff'.
 data DiffF syntax ann1 ann2 recur
-  -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation.
-  = Patch (Patch (TermF syntax  ann1        recur)
-                 (TermF syntax        ann2  recur))
+  -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Compare'd 'TermF's, consisting of syntax labelled with an annotation.
+  = Patch (Edit (TermF syntax  ann1        recur)
+                (TermF syntax        ann2  recur))
   -- | An unchanged node, consisting of syntax labelled with both the original annotations.
-  | Merge        (TermF syntax (ann1, ann2) recur)
+  | Merge       (TermF syntax (ann1, ann2) recur)
 
--- | Constructs a 'Diff' replacing one 'Term' with another recursively.
-replacing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
-replacing (Term (In a1 r1)) (Term (In a2 r2)) = replaceF (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))
+-- | Constructs a 'Diff' comparing one 'Term' with another recursively.
+comparing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
+comparing (Term (In a1 r1)) (Term (In a2 r2)) = compareF (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))
 
--- | Constructs a 'Diff' replacing one 'TermF' populated by further 'Diff's with another.
-replaceF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
-replaceF t1 t2 = Diff (Patch (Replace t1 t2))
+-- | Constructs a 'Diff' comparing one 'TermF' populated by further 'Diff's with another.
+compareF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
+compareF t1 t2 = Diff (Patch (Compare t1 t2))
 
 -- | Constructs a 'Diff' inserting a 'Term' recursively.
 inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2
@@ -75,8 +75,8 @@ merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann
 merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax))
 
 
-diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
-diffPatches = para $ \ diff -> case diff of
+diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Edit (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
+diffPatches = para $ \case
   Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch
   Merge merge -> foldMap snd merge
 

src/Data/Edit.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE LambdaCase #-}
+module Data.Edit
+( Edit(..)
+, edit
+, mergeEdit
+, fromMaybes
+) where
+
+import Control.Applicative ((<|>), liftA2)
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.Functor.Classes
+import GHC.Generics (Generic, Generic1)
+
+-- | The deletion, insertion, or comparison of values.
+data Edit a b
+  = Delete  a
+  | Insert    b
+  | Compare a b
+  deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
+
+
+-- | Eliminate an 'Edit' by case analysis.
+edit :: (l -> a) -> (r -> a) -> (l -> r -> a) -> Edit l r -> a
+edit delete insert compare = \case
+  Delete  a   -> delete a
+  Insert    b -> insert b
+  Compare a b -> compare a b
+
+-- | Extract the values from an 'Edit', combining 'Compare's with the passed function.
+mergeEdit :: (a -> a -> a) -> Edit a a -> a
+mergeEdit = edit id id
+
+fromMaybes :: Maybe a -> Maybe b -> Maybe (Edit a b)
+fromMaybes a b = liftA2 Compare a b <|> Delete <$> a <|> Insert <$> b
+
+
+instance Bifunctor Edit where
+  bimap = bimapDefault
+
+instance Bifoldable Edit where
+  bifoldMap = bifoldMapDefault
+
+instance Bitraversable Edit where
+  bitraverse f g = \case
+    Delete  a   -> Delete  <$> f a
+    Insert    b -> Insert  <$>         g b
+    Compare a b -> Compare <$> f a <*> g b
+
+instance Eq2 Edit where
+  liftEq2 eql eqr = curry $ \case
+    (Delete  a1   , Delete  a2   ) -> eql a1 a2
+    (Insert     b1, Insert     b2) ->              eqr b1 b2
+    (Compare a1 b1, Compare a2 b2) -> eql a1 a2 && eqr b1 b2
+    _                              -> False
+
+instance Ord2 Edit where
+  liftCompare2 cmpl cmpr = curry $ \case
+    (Delete  a1   , Delete  a2   ) -> cmpl a1 a2
+    (Delete  _    , _            ) -> LT
+    (Insert     b1, Insert     b2) ->               cmpr b1 b2
+    (Insert     _ , _            ) -> LT
+    (Compare a1 b1, Compare a2 b2) -> cmpl a1 a2 <> cmpr b1 b2
+    _                              -> GT
+
+instance Show2 Edit where
+  liftShowsPrec2 spl _ spr _ d = \case
+    Delete  a   -> showsUnaryWith  spl     "Delete"  d a
+    Insert    b -> showsUnaryWith      spr "Insert"  d   b
+    Compare a b -> showsBinaryWith spl spr "Compare" d a b

src/Data/Functor/Both.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE DerivingVia #-}
-
-module Data.Functor.Both
-( Both (..)
-, runBothWith
-) where
-
-import Data.Functor.Classes
-import Data.Functor.Classes.Generic
-import Data.Monoid.Generic
-import GHC.Generics
-
--- | A computation over both sides of a pair.
-data Both a = Both a a
-  deriving (Eq, Show, Ord, Functor, Foldable, Traversable, Generic1, Generic)
-  deriving Semigroup via GenericSemigroup (Both a)
-  deriving Monoid    via GenericMonoid (Both a)
-  deriving (Eq1, Show1, Ord1) via Generically Both
-
--- | Apply a function to `Both` sides of a computation.
--- The eliminator/catamorphism over 'Both'.
-runBothWith :: (a -> a -> b) -> Both a -> b
-runBothWith f (Both a b) = f a b

src/Data/ImportPath.hs

@@ -19,8 +19,9 @@ data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative
 importPath :: Text -> ImportPath
 importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathType path)
   where
-    pathType xs | not (T.null xs), T.head xs == '.' = Relative -- head call here is safe
-                | otherwise = NonRelative
+    pathType xs | startsWithDot xs = Relative -- head call here is safe
+                | otherwise        = NonRelative
+    startsWithDot t = fmap fst (T.uncons t) == Just '.'
 
 defaultAlias :: ImportPath -> Name
 defaultAlias = name . T.pack . takeFileName . unPath

src/Data/JSON/Fields.hs

@@ -9,6 +9,7 @@ module Data.JSON.Fields
   ) where
 
 import           Data.Aeson
+import           Data.Edit
 import qualified Data.Map as Map
 import           Data.Sum (Apply (..), Sum)
 import qualified Data.Text as Text
@@ -57,6 +58,11 @@ instance ToJSONFields Span where
 instance ToJSONFields Loc where
   toJSONFields Loc{..} = toJSONFields byteRange <> toJSONFields span
 
+instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Edit a b) where
+  toJSONFields (Insert a)    = [ "insert" .= object (toJSONFields a) ]
+  toJSONFields (Delete a)    = [ "delete" .= object (toJSONFields a) ]
+  toJSONFields (Compare a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]
+
 
 newtype JSONFields a = JSONFields { unJSONFields :: a }
 

src/Data/Patch.hs

@@ -1,76 +0,0 @@
-{-# OPTIONS_GHC -funbox-strict-fields #-}
-module Data.Patch
-( Patch(..)
-, after
-, before
-, patch
-) where
-
-import Prologue
-import Data.Aeson
-import Data.Align
-import Data.JSON.Fields
-
--- | An operation to replace, insert, or delete an item.
-data Patch a b
-  = Delete a
-  | Insert b
-  | Replace a b
-  deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
-
-
--- | Return the item from the after side of the patch.
-after :: Patch before after -> Maybe after
-after = patch (const Nothing) Just (\ _ b -> Just b)
-
--- | Return the item from the before side of the patch.
-before :: Patch before after -> Maybe before
-before = patch Just (const Nothing) (\ a _ -> Just a)
-
--- | Return both sides of a patch.
-patch :: (before -> result) -> (after -> result) -> (before -> after -> result) -> Patch before after -> result
-patch ifDelete _ _ (Delete a) = ifDelete a
-patch _ ifInsert _ (Insert b) = ifInsert b
-patch _ _ ifReplace (Replace a b) = ifReplace a b
-
-
--- Instances
-
-instance Bifunctor Patch where
-  bimap f _ (Delete a) = Delete (f a)
-  bimap _ g (Insert b) = Insert (g b)
-  bimap f g (Replace a b) = Replace (f a) (g b)
-
-instance Bifoldable Patch where
-  bifoldMap f _ (Delete a) = f a
-  bifoldMap _ g (Insert b) = g b
-  bifoldMap f g (Replace a b) = f a `mappend` g b
-
-instance Bitraversable Patch where
-  bitraverse f _ (Delete a) = Delete <$> f a
-  bitraverse _ g (Insert b) = Insert <$> g b
-  bitraverse f g (Replace a b) = Replace <$> f a <*> g b
-
-instance Bicrosswalk Patch where
-  bicrosswalk f _ (Delete a) = Delete <$> f a
-  bicrosswalk _ g (Insert b) = Insert <$> g b
-  bicrosswalk f g (Replace a b) = alignWith (these Delete Insert Replace) (f a) (g b)
-
-instance Eq2 Patch where
-  liftEq2 eqBefore eqAfter p1 p2 = case (p1, p2) of
-    (Delete a1, Delete a2) -> eqBefore a1 a2
-    (Insert b1, Insert b2) -> eqAfter b1 b2
-    (Replace a1 b1, Replace a2 b2) -> eqBefore a1 a2 && eqAfter b1 b2
-    _ -> False
-
-instance Show2 Patch where
-  liftShowsPrec2 spBefore _ spAfter _ d p = case p of
-    Delete a -> showsUnaryWith spBefore "Delete" d a
-    Insert b -> showsUnaryWith spAfter "Insert" d b
-    Replace a b -> showsBinaryWith spBefore spAfter "Replace" d a b
-
-
-instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Patch a b) where
-  toJSONFields (Insert a)    = [ "insert" .= object (toJSONFields a) ]
-  toJSONFields (Delete a)    = [ "delete" .= object (toJSONFields a) ]
-  toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]

src/Data/Project.hs

@@ -35,16 +35,26 @@ projectExtensions = extensionsForLanguage . projectLanguage
 projectFiles :: Project -> [File]
 projectFiles = fmap blobFile . projectBlobs
 
-readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
+readProjectFromPaths :: MonadIO m
+                     => Maybe Path.AbsRelDir -- ^ An optional root directory for the project
+                     -> Path.AbsRelFileDir   -- ^ A file or directory to parse. Passing a file path loads all files in that file's parent directory.
+                     -> Language
+                     -> [Path.AbsRelDir]     -- ^ Directories to exclude.
+                     -> m Project
 readProjectFromPaths maybeRoot path lang excludeDirs = do
-  isDir <- isDirectory path
-  let rootDir = if isDir
-      then fromMaybe path maybeRoot
-      else fromMaybe (takeDirectory path) maybeRoot
+  let rootDir :: Path.AbsRelDir
+      rootDir = case maybeRoot >>= Path.fromAbsRel of
+        -- If we were provided a root directory, use that.
+        Just root -> root
+        Nothing   -> case Path.fileFromFileDir path of
+          -- If we weren't and the path is a file, drop its file name.
+          Just fp -> Path.takeDirectory fp
+          -- Otherwise, load from the path.
+          Nothing -> Path.dirFromFileDir path
 
-  paths <- liftIO $ findFilesInDir (Path.absRel rootDir) exts (fmap Path.absRel excludeDirs)
+  paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
   blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
-  pure $ Project rootDir blobs lang excludeDirs
+  pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs)
   where
     toFile path = File (Path.toString path) lang
     exts = extensionsForLanguage lang

src/Data/Syntax/Declaration.hs

@@ -216,9 +216,7 @@ instance Evaluatable Class where
     currentScope' <- currentScope
 
     superScopes <- for classSuperclasses $ \superclass -> do
-      name <- case declaredName superclass of
-                Just name -> pure name
-                Nothing   -> gensym
+      name <- maybeM gensym (declaredName superclass)
       scope <- associatedScope (Declaration name)
       slot <- lookupSlot (Declaration name)
       superclassFrame <- scopedEnvironment =<< deref slot

src/Data/Syntax/Expression.hs

@@ -3,7 +3,7 @@
 module Data.Syntax.Expression where
 
 import Prelude hiding (null)
-import Prologue hiding (This, index, null)
+import Prologue hiding (index, null)
 
 import           Control.Abstract hiding (Bitwise (..), Call, Member)
 import           Data.Abstract.Evaluatable as Abstract hiding (Member)

src/Diffing/Algorithm.hs

@@ -5,7 +5,7 @@ module Diffing.Algorithm
   , Diffable (..)
   , Equivalence (..)
   , diff
-  , diffThese
+  , diffEdit
   , diffMaybe
   , linearly
   , byReplacing
@@ -17,6 +17,7 @@ module Diffing.Algorithm
 import Control.Effect.Carrier hiding ((:+:))
 import Control.Effect.NonDet
 import qualified Data.Diff as Diff
+import qualified Data.Edit as Edit
 import Data.Sum
 import Data.Term
 import GHC.Generics
@@ -53,9 +54,9 @@ instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where
 diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff
 diff a1 a2 = send (Diff a1 a2 pure)
 
--- | Diff a These of terms without specifying the algorithm to be used.
-diffThese :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => These term1 term2 -> Algorithm term1 term2 diff m diff
-diffThese = these byDeleting byInserting diff
+-- | Diff an 'Edit.Edit' of terms without specifying the algorithm to be used.
+diffEdit :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Edit.Edit term1 term2 -> Algorithm term1 term2 diff m diff
+diffEdit = Edit.edit byDeleting byInserting diff
 
 -- | Diff a pair of optional terms without specifying the algorithm to be used.
 diffMaybe :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff)
@@ -143,8 +144,8 @@ class Diffable f where
                  -> Algorithm term1 term2 diff m (f diff)
   algorithmFor = genericAlgorithmFor
 
-  tryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
-  default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
+  tryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
+  default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
   tryAlignWith f a b = to1 <$> gtryAlignWith f (from1 a) (from1 b)
 
   -- | Construct an algorithm to diff against positions inside an @f@.
@@ -207,30 +208,30 @@ instance Apply Diffable fs => Diffable (Sum fs) where
 instance Diffable Maybe where
   algorithmFor = diffMaybe
 
-  tryAlignWith f (Just a1) (Just a2) = Just <$> f (These a1 a2)
-  tryAlignWith f (Just a1) Nothing   = Just <$> f (This a1)
-  tryAlignWith f Nothing   (Just a2) = Just <$> f (That a2)
+  tryAlignWith f (Just a1) (Just a2) = Just <$> f (Edit.Compare a1 a2)
+  tryAlignWith f (Just a1) Nothing   = Just <$> f (Edit.Delete a1)
+  tryAlignWith f Nothing   (Just a2) = Just <$> f (Edit.Insert a2)
   tryAlignWith _ Nothing   Nothing   = pure Nothing
 
 -- | Diff two lists using RWS.
 instance Diffable [] where
   algorithmFor = byRWS
 
-  tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (These a1 a2) <*> tryAlignWith f as1 as2
-  tryAlignWith f []       as2      = traverse (f . That) as2
-  tryAlignWith f as1      []       = traverse (f . This) as1
+  tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2
+  tryAlignWith f []       as2      = traverse (f . Edit.Insert) as2
+  tryAlignWith f as1      []       = traverse (f . Edit.Delete) as1
 
 -- | Diff two non-empty lists using RWS.
 instance Diffable NonEmpty where
   algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty
 
-  tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2
+  tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2
 
 -- | A generic type class for diffing two terms defined by the Generic1 interface.
 class GDiffable f where
   galgorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff)
 
-  gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
+  gtryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
 
   gcomparableTo :: f term1 -> f term2 -> Bool
   gcomparableTo _ _ = True
@@ -271,7 +272,7 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
 instance GDiffable Par1 where
   galgorithmFor (Par1 a1) (Par1 a2) = Par1 <$> diff a1 a2
 
-  gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (These a b)
+  gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (Edit.Compare a b)
 
 -- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
 -- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).

src/Diffing/Algorithm/RWS.hs

@@ -15,7 +15,8 @@ module Diffing.Algorithm.RWS
 ) where
 
 import Control.Monad.State.Strict
-import Data.Diff (DiffF(..), deleting, inserting, merge, replacing)
+import Data.Diff (DiffF(..), comparing, deleting, inserting, merge)
+import Data.Edit
 import qualified Data.KdMap.Static as KdMap
 import Data.List (sortOn)
 import Data.Term as Term
@@ -37,7 +38,7 @@ rws :: (Foldable syntax, Functor syntax, Diffable syntax)
     -> [Edit (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))]
 rws _          _          as [] = Delete <$> as
 rws _          _          [] bs = Insert <$> bs
-rws canCompare _          [a] [b] = if canCompareTerms canCompare a b then [Copy a b] else [Insert b, Delete a]
+rws canCompare _          [a] [b] = if canCompareTerms canCompare a b then [Compare a b] else [Insert b, Delete a]
 rws canCompare equivalent as bs
   = ses equivalent as bs
   & mapContiguous [] []
@@ -46,15 +47,15 @@ rws canCompare equivalent as bs
         -- Map contiguous sequences of unmapped terms separated by SES-mapped equivalencies.
         mapContiguous as bs [] = mapSimilar (reverse as) (reverse bs)
         mapContiguous as bs (first : rest) = case first of
-          Delete a   -> mapContiguous (a : as)      bs  rest
-          Insert   b -> mapContiguous      as  (b : bs) rest
-          Copy   _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest)
+          Delete  a   -> mapContiguous (a : as)      bs  rest
+          Insert    b -> mapContiguous      as  (b : bs) rest
+          Compare _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest)
 
         -- Map comparable, mutually similar terms, inserting & deleting surrounding terms.
         mapSimilar as' bs' = go as bs
           where go as [] = Delete . snd <$> as
                 go [] bs = Insert . snd <$> bs
-                go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Copy (snd a) (snd b)]
+                go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Compare (snd a) (snd b)]
                            | otherwise = [Insert (snd b), Delete (snd a)]
                 go as@((i, _) : _) ((j, b) : restB) =
                   fromMaybe (Insert b : go as restB) $ do
@@ -66,7 +67,7 @@ rws canCompare equivalent as bs
                     guard (j == j')
                     -- Delete any elements of as before the selected element.
                     let (deleted, _ : restA) = span ((< i') . fst) as
-                    pure $! (Delete . snd <$> deleted) <> (Copy a b : go restA restB)
+                    pure $! (Delete . snd <$> deleted) <> (Compare a b : go restA restB)
                 (as, bs) = (zip [0..] as', zip [0..] bs')
                 (kdMapA, kdMapB) = (toKdMap as, toKdMap bs)
 
@@ -158,7 +159,7 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b)
           _ | m <= 0 -> 0
           Merge body -> sum (fmap ($ pred m) body)
           body -> succ (sum (fmap ($ pred m) body))
-        approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
+        approximateDiff a b = maybe (comparing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . edit deleting inserting approximateDiff) (termOut a) (termOut b))
 
 
 data Label syntax where

src/Diffing/Algorithm/SES.hs

@@ -1,35 +1,13 @@
-{-# LANGUAGE BangPatterns, GADTs, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns, GADTs, MultiParamTypeClasses, ScopedTypeVariables #-}
 module Diffing.Algorithm.SES
-( Edit(..)
-, toThese
-, ses
+( ses
 ) where
 
 import Data.Array ((!))
 import qualified Data.Array as Array
-import Data.Bifunctor
+import Data.Edit
 import Data.Foldable (find, toList)
 import Data.Ix
-import Data.These
-
--- | An edit script, i.e. a sequence of changes/copies of elements.
-data Edit a b
-  = Delete a
-  | Insert b
-  | Copy a b
-  deriving (Eq, Functor, Ord, Show)
-
-instance Bifunctor Edit where
-  bimap f g = \case
-    Delete a -> Delete (f a)
-    Insert b -> Insert (g b)
-    Copy a b -> Copy (f a) (g b)
-
-toThese :: Edit a b -> These a b
-toThese = \case
-  Delete a -> This a
-  Insert b -> That b
-  Copy a b -> These a b
 
 data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: [Edit a b] }
   deriving (Eq, Show)
@@ -78,11 +56,11 @@ ses eq as' bs'
         slideFrom (Endpoint x y script)
           | Just a <- as !? x
           , Just b <- bs !? y
-          , a `eq` b  = slideFrom (Endpoint (succ x) (succ y) (Copy a b : script))
+          , a `eq` b  = slideFrom (Endpoint (succ x) (succ y) (Compare a b : script))
           | otherwise =            Endpoint       x        y              script
 
 
 (!?) :: Ix i => Array.Array i a -> i -> Maybe a
-(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
-         | otherwise = Nothing
+v !? i | inRange (Array.bounds v) i, !a <- v ! i = Just a
+       | otherwise                               = Nothing
 {-# INLINE (!?) #-}

src/Diffing/Interpreter.hs

@@ -9,10 +9,10 @@ import Control.Effect.Carrier
 import Control.Effect.Cull
 import Control.Effect.NonDet
 import qualified Data.Diff as Diff
+import Data.Edit (Edit, edit)
 import Data.Term
 import Diffing.Algorithm
 import Diffing.Algorithm.RWS
-import Diffing.Algorithm.SES (toThese)
 import Prologue
 
 -- | Diff two à la carte terms recursively.
@@ -20,7 +20,7 @@ diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
           => Term syntax ann1
           -> Term syntax ann2
           -> Diff.Diff syntax ann1 ann2
-diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2')))))
+diffTerms t1 t2 = stripDiff (fromMaybe (Diff.comparing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2')))))
   where (t1', t2') = ( defaultFeatureVectorDecorator t1
                      , defaultFeatureVectorDecorator t2)
 
@@ -37,12 +37,12 @@ class Bifoldable (DiffFor term) => DiffTerms term where
   -- Note that the dependency means that the diff type is in 1:1 correspondence with the term type. This allows subclasses of 'DiffTerms' to receive e.g. @'DiffFor' term a b@ without incurring ambiguity, since every diff type is unique to its term type.
   type DiffFor term = (diff :: * -> * -> *) | diff -> term
 
-  -- | Diff a 'These' of terms.
-  diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2
+  -- | Diff an 'Edit' of terms.
+  diffTermPair :: Edit (term ann1) (term ann2) -> DiffFor term ann1 ann2
 
 instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where
   type DiffFor (Term syntax) = Diff.Diff syntax
-  diffTermPair = these Diff.deleting Diff.inserting diffTerms
+  diffTermPair = edit Diff.deleting Diff.inserting diffTerms
 
 
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
@@ -71,10 +71,10 @@ instance ( Alternative m
         (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig)
         (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where
   eff (L op) = case op of
-    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
-    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k
-    RWS as bs k -> traverse (runDiff . diffThese . toThese) (rws comparableTerms equivalentTerms as bs) >>= k
+    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.comparing t1 t2) >>= k
+    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffEdit) f1 f2 >>= k
+    RWS as bs k -> traverse (runDiff . diffEdit) (rws comparableTerms equivalentTerms as bs) >>= k
     Delete a k -> k (Diff.deleting a)
     Insert b k -> k (Diff.inserting b)
-    Replace a b k -> k (Diff.replacing a b)
+    Replace a b k -> k (Diff.comparing a b)
   eff (R other) = DiffC . eff . handleCoercible $ other

src/Prologue.hs

@@ -16,7 +16,6 @@ import Data.Bits as X
 import Data.ByteString as X (ByteString)
 import Data.Coerce as X
 import Data.Int as X (Int8, Int16, Int32, Int64)
-import Data.Functor.Both as X (Both (Both), runBothWith)
 import Data.Either as X (fromLeft, fromRight)
 import Data.IntMap as X (IntMap)
 import Data.IntSet as X (IntSet)
@@ -30,7 +29,6 @@ import Data.Semilattice.Lower as X (Lower(..))
 import Data.Set as X (Set)
 import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject)
 import Data.Text as X (Text)
-import Data.These as X
 import Data.Word as X (Word8, Word16, Word32, Word64)
 
 import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo)

src/Rendering/Graph.hs

@@ -14,8 +14,8 @@ import Control.Effect.Reader
 import Control.Effect.State
 import Control.Lens
 import Data.Diff
+import Data.Edit
 import Data.Graph
-import Data.Patch
 import Data.ProtoLens (defMessage)
 import Data.String (IsString (..))
 import Data.Term
@@ -99,7 +99,7 @@ instance (ConstructorName syntax, Foldable syntax) =>
     Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 . DiffTreeVertex'Inserted $ defMessage
                                           & P.term .~ T.pack (constructorName syntax)
                                           & P.maybe'span .~ ann a2
-    Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
+    Patch (Compare t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
       i <- fresh
       parent <- ask
       let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1)

src/Rendering/JSON.hs

@@ -15,9 +15,8 @@ module Rendering.JSON
 
 import Data.Aeson (ToJSON, toJSON, object, (.=))
 import Data.Aeson as A
-import Data.JSON.Fields
 import Data.Blob
-import Data.Patch
+import Data.JSON.Fields
 import Data.Text (pack)
 import GHC.TypeLits
 import Prologue
@@ -56,8 +55,8 @@ newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair }
   deriving (Eq, Show)
 
 instance ToJSON JSONStat where
-  toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (getBlobPair jsonStatBlobs)))
-  toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (getBlobPair jsonStatBlobs))))
+  toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs)
+  toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs))
 
 -- | Render a term to a value representing its JSON.
 renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON

src/Rendering/TOC.hs

@@ -12,13 +12,12 @@ module Rendering.TOC
 
 import Prologue hiding (index)
 import Analysis.TOCSummary
-import Data.Align (bicrosswalk)
 import Data.Aeson (ToJSON(..), Value, (.=), object)
 import Data.Diff
+import Data.Edit
 import Data.Language as Language
 import Data.List (sortOn)
 import qualified Data.Map.Monoidal as Map
-import Data.Patch
 import Data.Term
 import qualified Data.Text as T
 import Source.Loc
@@ -77,12 +76,17 @@ tableOfContentsBy :: (Foldable f, Functor f)
                   => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
                   -> Diff f ann ann                       -- ^ The diff to compute the table of contents for.
                   -> [(Change, a)]                        -- ^ A list of entries for relevant changed nodes in the diff.
-tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of
-  Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just []
+tableOfContentsBy selector = fromMaybe [] . cata (\case
+  Patch edit -> (pure . patchEntry <$> select (bimap selector selector edit)) <> bifoldMap fold fold edit <> Just []
   Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of
     (Just a, Just entries) -> Just ((Changed, a) : entries)
     (_     , entries)      -> entries)
-  where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,))
+  where patchEntry = edit (Deleted,) (Inserted,) (const (Replaced,))
+
+        select = \case
+          Delete  a   -> Delete <$> a
+          Insert    b -> Insert <$> b
+          Compare a b -> liftA2 Compare a b <|> Delete <$> a <|> Insert <$> b
 
 
 data DedupeKey = DedupeKey !Kind {-# UNPACK #-} !T.Text

src/Semantic/Analysis.hs

@@ -46,10 +46,10 @@ type DomainC term address value m
 -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module.
 evaluate :: ( Carrier outerSig outer
             , derefSig ~ (Deref value :+: allocatorSig)
-            , derefC ~ (DerefC address value allocatorC)
+            , derefC ~ DerefC address value allocatorC
             , Carrier derefSig derefC
             , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig)
-            , allocatorC ~ (AllocatorC address (ReaderC ModuleInfo outer))
+            , allocatorC ~ AllocatorC address (ReaderC ModuleInfo outer)
             , Carrier allocatorSig allocatorC
             , Effect outerSig
             , Member Fresh outerSig

src/Semantic/Api/Bridge.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FunctionalDependencies, LambdaCase #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Semantic.Api.Bridge
   ( APIBridge (..)
   , APIConvert (..)
@@ -7,6 +7,7 @@ module Semantic.Api.Bridge
 
 import           Control.Lens
 import qualified Data.Blob as Data
+import qualified Data.Edit as Data
 import qualified Data.Language as Data
 import           Data.ProtoLens (defMessage)
 import qualified Data.Text as T
@@ -78,11 +79,11 @@ instance APIConvert API.BlobPair Data.BlobPair where
   converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where
 
     apiBlobPairToBlobPair blobPair = case (blobPair^.maybe'before, blobPair^.maybe'after) of
-      (Just before, Just after) -> Just $ Data.Diffing (before^.bridging) (after^.bridging)
-      (Just before, Nothing)    -> Just $ Data.Deleting (before^.bridging)
-      (Nothing, Just after)     -> Just $ Data.Inserting (after^.bridging)
+      (Just before, Just after) -> Just $ Data.Compare (before^.bridging) (after^.bridging)
+      (Just before, Nothing)    -> Just $ Data.Delete (before^.bridging)
+      (Nothing, Just after)     -> Just $ Data.Insert (after^.bridging)
       _                         -> Nothing
 
-    blobPairToApiBlobPair (Data.Diffing before after) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ (bridging #? after)
-    blobPairToApiBlobPair (Data.Inserting after)      = defMessage & P.maybe'before .~ Nothing & P.maybe'after .~ (bridging #? after)
-    blobPairToApiBlobPair (Data.Deleting before)      = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ Nothing
+    blobPairToApiBlobPair (Data.Compare before after) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ (bridging #? after)
+    blobPairToApiBlobPair (Data.Insert after)         = defMessage & P.maybe'before .~ Nothing & P.maybe'after .~ (bridging #? after)
+    blobPairToApiBlobPair (Data.Delete before)        = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ Nothing

src/Semantic/Api/Diffs.hs

@@ -18,6 +18,7 @@ import           Control.Lens
 import           Control.Monad.IO.Class
 import           Data.Blob
 import           Data.ByteString.Builder
+import           Data.Edit
 import           Data.Graph
 import           Data.JSON.Fields
 import           Data.Language
@@ -156,9 +157,9 @@ diffWith
 diffWith parsers render = parsePairWith parsers (render <=< diffTerms)
 
 diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m)
-  => These (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann)
+  => Edit (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann)
 diffTerms terms = time "diff" languageTag $ do
   let diff = diffTermPair (bimap snd snd terms)
   diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
   where languageTag = languageTagForBlobPair blobs
-        blobs = BlobPair (bimap fst fst terms)
+        blobs = bimap fst fst terms

src/Semantic/Api/TOCSummaries.hs

@@ -18,6 +18,7 @@ import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Blob
 import           Data.ByteString.Builder
+import           Data.Edit
 import           Data.Either (partitionEithers)
 import           Data.Function (on)
 import           Data.Functor.Classes
@@ -30,7 +31,6 @@ import           Data.ProtoLens (defMessage)
 import           Data.Semilattice.Lower
 import           Data.Term (Term)
 import qualified Data.Text as T
-import           Data.These (These, fromThese)
 import           Diffing.Algorithm (Diffable)
 import qualified Diffing.Algorithm.SES as SES
 import qualified Language.Java as Java
@@ -107,7 +107,7 @@ summarizeDiffParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeDi
 summarizeDiffParsers = allParsers
 
 class SummarizeDiff term where
-  summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => These (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary]
+  summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary]
 
 instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where
   summarizeTerms = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where
@@ -123,16 +123,16 @@ deriving via (ViaTags Python.Term) instance SummarizeDiff Python.Term
 newtype ViaTags t a = ViaTags (t a)
 
 instance Tagging.ToTags t => SummarizeDiff (ViaTags t) where
-  summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . uncurry (SES.ses compare) . fromThese [] [] . bimap (uncurry go) (uncurry go) $ terms where
+  summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . edit (map Delete) (map Insert) (SES.ses compare) . bimap (uncurry go) (uncurry go) $ terms where
     go blob (ViaTags t) = Tagging.tags (blobSource blob) t
-    lang = languageForBlobPair (BlobPair (bimap fst fst terms))
-    (s1, s2) = fromThese mempty mempty (bimap (blobSource . fst) (blobSource . fst) terms)
+    lang = languageForBlobPair (bimap fst fst terms)
+    (s1, s2) = edit (,mempty) (mempty,) (,) (bimap (blobSource . fst) (blobSource . fst) terms)
     compare = liftA2 (&&) <$> ((==) `on` Tag.kind) <*> ((==) `on` Tag.name)
 
     toChange = \case
-      SES.Delete tag -> (Deleted,)  <$> toDecl tag
-      SES.Insert tag -> (Inserted,) <$> toDecl tag
-      SES.Copy t1 t2
+      Delete tag -> (Deleted,)  <$> toDecl tag
+      Insert tag -> (Inserted,) <$> toDecl tag
+      Compare t1 t2
         | Source.slice s1 (byteRange (Tag.loc t1)) /= Source.slice s2 (byteRange (Tag.loc t2))
                      -> (Changed,) <$> toDecl t2
         | otherwise  -> Nothing

src/Semantic/CLI.hs

@@ -6,7 +6,6 @@ import           Control.Effect.Reader
 import           Control.Exception as Exc (displayException)
 import           Data.Blob
 import           Data.Blob.IO
-import qualified Data.ByteString.Char8 as B
 import           Data.Handle
 import qualified Data.Language as Language
 import           Data.List (intercalate)
@@ -18,7 +17,6 @@ import           Semantic.Api hiding (File)
 import           Semantic.Config
 import qualified Semantic.Graph as Graph
 import qualified Semantic.Task as Task
-import qualified Semantic.Git as Git
 import           Semantic.Task.Files
 import           Semantic.Telemetry
 import qualified Semantic.Telemetry.Log as Log
@@ -99,7 +97,7 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change
               <|> flag'                                    (diffSummaryBuilder JSON)          (long "toc"         <> help "Output JSON table of contents diff summary")
               <|> flag'                                    (parseDiffBuilder DiffDotGraph)    (long "dot"         <> help "Output the diff as a DOT graph")
               <|> flag'                                    (parseDiffBuilder DiffShow)        (long "show"        <> help "Output using the Show instance (debug only, format subject to change without notice)")
-      filesOrStdin <- Right <$> some (Both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
+      filesOrStdin <- Right <$> some ((,) <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
       pure $ Task.readBlobPairs filesOrStdin >>= runReader languageModes . renderer
 
 parseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
@@ -134,14 +132,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
         <|> flag' (parseTermBuilder TermQuiet)
                   (  long "quiet"
                   <> help "Don't produce output, but show timing stats")
-      filesOrStdin <- FilesFromGitRepo
-                      <$> option str (long "gitDir" <> help "A .git directory to read from")
-                      <*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
-                      <*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
-                        <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
-                        <|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
-                        <|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
-                  <|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
+      filesOrStdin <- FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
                   <|> pure (FilesFromHandle stdin)
       pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer
 
@@ -169,9 +160,9 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
         _     -> pure $! Project "/" mempty Language.Unknown mempty
     readProjectRecursively = makeReadProjectRecursivelyTask
       <$> option auto (long "language" <> help "The language for the analysis.")
-      <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
-      <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
-      <*> argument str (metavar "DIR")
+      <*> optional (pathOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
+      <*> many (pathOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
+      <*> argument path (metavar "PATH")
     makeReadProjectRecursivelyTask language rootDir excludeDirs dir = Task.readProject rootDir dir language excludeDirs
     makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer
 
@@ -183,12 +174,6 @@ languageModes = Language.PerLanguageModes
                   <> value Language.ALaCarte
                   <> showDefault)
 
-shaReader :: ReadM Git.OID
-shaReader = eitherReader parseSha
-  where parseSha arg = if length arg == 40 || arg == "HEAD"
-          then Right (Git.OID (B.pack arg))
-          else Left (arg <> " is not a valid sha1")
-
 filePathReader :: ReadM File
 filePathReader = fileForPath <$> str
 

src/Semantic/Git.hs

@@ -1,109 +0,0 @@
-module Semantic.Git
-  ( -- Primary (partial) API for cmd line git
-    clone
-  , lsTree
-  , catFile
-
-  -- Intermediate datatypes
-  , TreeEntry(..)
-  , ObjectType(..)
-  , ObjectMode(..)
-  , OID(..)
-
-  -- Testing Purposes
-  , parseEntries
-  , parseEntry
-  ) where
-
-import Prologue
-
-import           Data.Attoparsec.ByteString (Parser)
-import           Data.Attoparsec.ByteString as AP
-import           Data.ByteString (ByteString)
-import           Data.ByteString.Internal (w2c)
-import qualified Data.ByteString.UTF8 as UTF8
-import qualified Data.ByteString.Streaming as ByteStream
-import qualified Data.Attoparsec.ByteString.Streaming as AP.Streaming
-import           Data.Char
-import           Data.Either (fromRight)
-import           Data.Text as Text
-import           Text.Parser.Combinators (sepEndBy)
-import qualified Streaming.Process
-import qualified System.Process as Process
-import qualified Source.Source as Source
-
--- | git clone --bare
-clone :: Text -> FilePath -> IO ()
-clone url path = Process.callProcess "git"
-  ["clone", "--bare", Text.unpack url, path]
-
--- | Runs @git cat-file -p@. Throws 'ProcessExitedUnsuccessfully' if the
--- underlying git command returns a nonzero exit code. Loads the contents
--- of the file into memory all at once and strictly.
-catFile :: FilePath -> OID -> IO Source.Source
-catFile gitDir (OID oid) =
-  let process = Process.proc "git" ["-C", gitDir, "cat-file", "-p", UTF8.toString oid]
-      consumeStdout stream = Streaming.Process.withProcessOutput stream ByteStream.toStrict_
-  in Source.fromUTF8 <$> Streaming.Process.withStreamProcess process consumeStdout
-
--- | git ls-tree -rz
-lsTree :: FilePath -> OID -> IO [TreeEntry]
-lsTree gitDir (OID sha) =
-  let process        = Process.proc "git" ["-C", gitDir, "ls-tree", "-rz", UTF8.toString sha]
-      allEntries     = (entryParser `sepEndBy` AP.word8 0) <* AP.endOfInput
-      ignoreFailures = fmap (fromRight [] . fst)
-  in Streaming.Process.withStreamProcess process $
-     \stream -> Streaming.Process.withProcessOutput stream (ignoreFailures . AP.Streaming.parse allEntries)
-
-
--- | Parses an list of entries separated by \NUL, and on failure return []
-parseEntries :: ByteString -> [TreeEntry]
-parseEntries = fromRight [] . AP.parseOnly everything
-  where
-    everything = AP.sepBy entryParser (AP.word8 0)
-
--- | Parse the entire input with entryParser, and on failure return a default
--- For testing purposes only
-parseEntry :: ByteString -> Either String TreeEntry
-parseEntry = AP.parseOnly (entryParser <* AP.endOfInput)
-
--- | Parses a TreeEntry
-entryParser :: Parser TreeEntry
-entryParser = TreeEntry
-  <$> modeParser <* AP.word8 space
-  <*> typeParser <* AP.word8 space
-  <*> oidParser <* AP.word8 tab
-  <*> (UTF8.toString <$> AP.takeWhile (/= nul))
-    where
-      char = fromIntegral @Int @Word8 . ord
-      space = char ' '
-      tab = char '\t'
-      nul = char '\NUL'
-      typeParser = AP.choice [BlobObject <$ "blob", TreeObject <$ "tree", OtherObjectType <$ AP.takeWhile (isAlphaNum . w2c)]
-      modeParser = AP.choice [NormalMode <$ "100644", ExecutableMode <$ "100755", SymlinkMode <$ "120000", TreeMode <$ "040000", OtherMode <$ AP.takeWhile (isAlphaNum . w2c)]
-      oidParser = OID <$> AP.takeWhile (isHexDigit . w2c)
-
-newtype OID = OID ByteString
-  deriving (Eq, Show, Ord)
-
-data ObjectMode
-  = NormalMode
-  | ExecutableMode
-  | SymlinkMode
-  | TreeMode
-  | OtherMode
-  deriving (Eq, Show)
-
-data ObjectType
-  = BlobObject
-  | TreeObject
-  | OtherObjectType
-  deriving (Eq, Show)
-
-data TreeEntry
-  = TreeEntry
-  { treeEntryMode :: ObjectMode
-  , treeEntryType :: ObjectType
-  , treeEntryOid  :: OID
-  , treeEntryPath :: FilePath
-  } deriving (Eq, Show)

src/Semantic/Task.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
-             ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+             ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( TaskC
 , Level(..)

src/Semantic/Task/Files.hs

@@ -14,7 +14,6 @@ module Semantic.Task.Files
   , Handle (..)
   , FilesC(..)
   , FilesArg(..)
-  , PathFilter(..)
   ) where
 
 import           Control.Effect.Carrier
@@ -28,7 +27,6 @@ import           Data.Language
 import           Data.Project
 import           Prelude hiding (readFile)
 import           Prologue hiding (catch)
-import qualified Semantic.Git as Git
 import           Semantic.IO
 import qualified System.IO as IO hiding (withBinaryFile)
 import qualified System.Path.IO as IO (withBinaryFile)
@@ -38,22 +36,15 @@ data Source blob where
   FromPath       :: File                            -> Source Blob
   FromHandle     :: Handle 'IO.ReadMode             -> Source [Blob]
   FromDir        :: Path.AbsRelDir                  -> Source [Blob]
-  FromGitRepo    :: FilePath -> Git.OID -> PathFilter -> Source [Blob]
-  FromPathPair   :: Both File                       -> Source BlobPair
+  FromPathPair   :: File -> File                    -> Source BlobPair
   FromPairHandle :: Handle 'IO.ReadMode             -> Source [BlobPair]
 
 data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)
 
-data PathFilter
-  = ExcludePaths [FilePath]
-  | ExcludeFromHandle (Handle 'IO.ReadMode)
-  | IncludePaths [FilePath]
-  | IncludePathsFromHandle (Handle 'IO.ReadMode)
-
 -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
 data Files (m :: * -> *) k
   = forall a . Read (Source a)                                     (a -> m k)
-  | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> m k)
+  | ReadProject (Maybe Path.AbsRelDir) Path.AbsRelFileDir Language [Path.AbsRelDir] (Project -> m k)
   | FindFiles Path.AbsRelDir [String] [Path.AbsRelDir] ([Path.AbsRelFile] -> m k)
   | Write Destination B.Builder                               (m k)
 
@@ -84,11 +75,7 @@ instance (Member (Error SomeException) sig, Member Catch sig, MonadIO m, Carrier
     Read (FromPath path) k                                    -> rethrowing (readBlobFromFile' path) >>= k
     Read (FromHandle handle) k                                -> rethrowing (readBlobsFromHandle handle) >>= k
     Read (FromDir dir) k                                      -> rethrowing (readBlobsFromDir dir) >>= k
-    Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths mempty) >>= k
-    Read (FromGitRepo path sha (ExcludeFromHandle handle)) k  -> rethrowing (readPathsFromHandle handle >>= (\x -> readBlobsFromGitRepo path sha x mempty)) >>= k
-    Read (FromGitRepo path sha (IncludePaths includePaths)) k -> rethrowing (readBlobsFromGitRepo path sha mempty includePaths) >>= k
-    Read (FromGitRepo path sha (IncludePathsFromHandle h)) k  -> rethrowing (readPathsFromHandle h >>= readBlobsFromGitRepo path sha mempty) >>= k
-    Read (FromPathPair paths) k                               -> rethrowing (runBothWith readFilePair paths) >>= k
+    Read (FromPathPair p1 p2) k                               -> rethrowing (readFilePair p1 p2) >>= k
     Read (FromPairHandle handle) k                            -> rethrowing (readBlobPairsFromHandle handle) >>= k
     ReadProject rootDir dir language excludeDirs k            -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k
     FindFiles dir exts excludeDirs k                          -> rethrowing (findFilesInDir dir exts excludeDirs) >>= k
@@ -102,7 +89,6 @@ readBlob file = send (Read (FromPath file) pure)
 data FilesArg
   = FilesFromHandle (Handle 'IO.ReadMode)
   | FilesFromPaths [File]
-  | FilesFromGitRepo FilePath Git.OID PathFilter
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
 readBlobs :: (Member Files sig, Carrier sig m, MonadIO m) => FilesArg -> m [Blob]
@@ -113,14 +99,13 @@ readBlobs (FilesFromPaths [path]) = do
     then send (Read (FromDir (Path.path (filePath path))) pure)
     else pure <$> send (Read (FromPath path) pure)
 readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
-readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure)
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
+readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair]
 readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
-readBlobPairs (Right paths) = traverse (send . flip Read pure . FromPathPair) paths
+readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths
 
-readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
+readProject :: (Member Files sig, Carrier sig m) => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project
 readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure)
 
 findFiles :: (Member Files sig, Carrier sig m) => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile]

src/Serializing/SExpression.hs

@@ -8,7 +8,7 @@ module Serializing.SExpression
 import Analysis.ConstructorName
 import Data.ByteString.Builder
 import Data.Diff
-import Data.Patch
+import Data.Edit
 import Data.Term
 import Prelude
 import Prologue
@@ -43,6 +43,6 @@ instance (ConstructorName syntax, Foldable syntax, Show ann1, Show ann2) => ToSE
   toSExpression options diff n = case diff of
     Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> namedBranch options term n <> "-}"
     Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> namedBranch options term n <> "+}"
-    Patch (Replace term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> namedBranch options term1 n
+    Patch (Compare term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> namedBranch options term1 n
                                 <> nl (n + 1) <> pad (n - 1) <> "->" <> namedBranch options term2 n <> " }"
     Merge term -> nl n <> pad n <> namedBranch options term n

src/Serializing/SExpression/Precise.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Serializing.SExpression.Precise
 ( serializeSExpression
 , ToSExpression(..)

src/Tags/Taggable.hs

@@ -12,7 +12,7 @@ identify a new syntax as Taggable, you need to:
 constructor name of this syntax.
 
 -}
-{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
 module Tags.Taggable
 ( Tagger
 , Token(..)

src/Tags/Tagging.hs

@@ -57,12 +57,11 @@ contextualizing :: ( Member (State [ContextToken]) sig
 contextualizing source toKind = Streaming.mapMaybeM $ \case
   Enter x r -> Nothing <$ enterScope (x, r)
   Exit  x r -> Nothing <$ exitScope (x, r)
-  Iden iden loc docsLiteralRange -> get @[ContextToken] >>= pure . \case
-    ((x, r):("Context", cr):_) | Just kind <- toKind x
-      -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr))
-    ((x, r):_) | Just kind <- toKind x
-      -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange)
-    _ -> Nothing
+  Iden iden loc docsLiteralRange -> fmap go (get @[ContextToken]) where
+    go = \case
+      ((x, r):("Context", cr):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr))
+      ((x, r):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange)
+      _ -> Nothing
   where
     slice = stripEnd . Source.toText . Source.slice source
     firstLine = T.take 180 . fst . breakOn "\n"

test/Data/Functor/Listable.hs

@@ -20,10 +20,9 @@ import qualified Analysis.TOCSummary as ToC
 import Data.Abstract.ScopeGraph (AccessControl(..))
 import Data.Bifunctor.Join
 import Data.Diff
-import Data.Functor.Both
+import Data.Edit
 import qualified Data.Language as Language
 import Data.List.NonEmpty
-import Data.Patch
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Comment as Comment
 import qualified Data.Syntax.Declaration as Declaration
@@ -122,9 +121,6 @@ instance Listable1 NonEmpty where
 instance Listable2 p => Listable1 (Join p) where
   liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join
 
-instance Listable1 Both where
-  liftTiers tiers = liftCons2 tiers tiers Both
-
 instance Listable1 f => Listable2 (TermF f) where
   liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In
 
@@ -160,10 +156,10 @@ instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff synt
   tiers = tiers2
 
 
-instance Listable2 Patch where
-  liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Replace
+instance Listable2 Edit where
+  liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Compare
 
-instance (Listable a, Listable b) => Listable (Patch a b) where
+instance (Listable a, Listable b) => Listable (Edit a b) where
   tiers = tiers2
 
 

test/Diffing/Algorithm/RWS/Spec.hs

@@ -7,11 +7,9 @@ import Data.Functor.Listable (ListableSyntax)
 import Data.Sum
 import qualified Data.Syntax as Syntax
 import Data.Term
-import Data.These
 import Diffing.Algorithm (comparableTerms)
 import Diffing.Interpreter (stripDiff)
 import Diffing.Algorithm.RWS
-import Diffing.Algorithm.SES
 import Diffing.Interpreter.Spec (afterTerm, beforeTerm)
 import Test.Hspec.LeanCheck
 import SpecHelpers
@@ -31,16 +29,16 @@ spec = do
       \ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax ()])
                         tbs = decorate <$> (bs :: [Term ListableSyntax ()])
                         wrap = termIn emptyAnnotation . inject
-                        diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffThese . toThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
+                        diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffEdit <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
         (beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs)))
 
     it "produces unbiased insertions within branches" $
       let (a, b) = (decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "a")) ])), decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "b")) ]))) in
-      fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Copy b b ]
+      fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Compare b b ]
 
   where decorate = defaultFeatureVectorDecorator
 
-        diffThese = these deleting inserting replacing
+        diffEdit = edit deleting inserting comparing
 
 stripTerm :: Functor f => Term f (FeatureVector, ()) -> Term f ()
 stripTerm = fmap snd

test/Diffing/Algorithm/SES/Spec.hs

@@ -1,6 +1,6 @@
 module Diffing.Algorithm.SES.Spec (spec) where
 
-import Data.These
+import Data.Edit
 import Diffing.Algorithm.SES
 import Test.Hspec
 import Test.Hspec.LeanCheck
@@ -8,17 +8,17 @@ import Test.Hspec.LeanCheck
 spec :: Spec
 spec = do
   describe "ses" $ do
-    prop "returns equal lists in These" $
-      \ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Copy as as
+    prop "returns equal lists in Compare" $
+      \ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Compare as as
 
-    prop "returns deletions in This" $
+    prop "returns deletions in Delete" $
       \ as -> (ses (==) as [] :: [Edit Char Char]) `shouldBe` fmap Delete as
 
-    prop "returns insertions in That" $
+    prop "returns insertions in Insert" $
       \ bs -> (ses (==) [] bs :: [Edit Char Char]) `shouldBe` fmap Insert bs
 
     prop "returns all elements individually for disjoint inputs" $
       \ as bs -> length (ses (==) ((,) 0 <$> as :: [(Int, Char)]) ((,) 1 <$> bs :: [(Int, Char)])) `shouldBe` length as + length bs
 
     prop "is lossless w.r.t. both input elements & ordering" $
-      \ as bs -> foldr (\ each (as, bs) -> these (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) (toThese each)) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs)
+      \ as bs -> foldr (\ each (as, bs) -> edit (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) each) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs)

test/Diffing/Interpreter/Spec.hs

@@ -8,17 +8,15 @@ import Data.Functor.Foldable (cata)
 import Data.Functor.Listable
 import Data.Maybe
 import Data.Mergeable
-import Data.Patch (after, before)
 import Data.Sum
 import Data.Term
-import Data.These
 import Diffing.Interpreter
 import qualified Data.Syntax as Syntax
 import Test.Hspec (Spec, describe, it)
 import Test.Hspec.Expectations
 import Test.Hspec.LeanCheck
 import Test.LeanCheck.Core
-import SpecHelpers ()
+import SpecHelpers (Edit(..), edit)
 
 spec :: Spec
 spec = do
@@ -26,7 +24,7 @@ spec = do
     it "returns a replacement when comparing two unicode equivalent terms" $
       let termA = termIn emptyAnnotation (inject (Syntax.Identifier "t\776"))
           termB = termIn emptyAnnotation (inject (Syntax.Identifier "\7831")) in
-          diffTerms termA termB `shouldBe` replacing termA (termB :: Term ListableSyntax ())
+          diffTerms termA termB `shouldBe` comparing termA (termB :: Term ListableSyntax ())
 
     prop "produces correct diffs" $
       \ a b -> let diff = diffTerms a b :: Diff ListableSyntax () () in
@@ -61,11 +59,11 @@ spec = do
 
   describe "diffTermPair" $ do
     prop "produces an Insert when the first term is missing" $ do
-      \ after -> let diff = diffTermPair (That after) :: Diff ListableSyntax () () in
+      \ after -> let diff = diffTermPair (Insert after) :: Diff ListableSyntax () () in
         diff `shouldBe` inserting after
 
     prop "produces a Delete when the second term is missing" $ do
-      \ before -> let diff = diffTermPair (This before) :: Diff ListableSyntax () () in
+      \ before -> let diff = diffTermPair (Delete before) :: Diff ListableSyntax () () in
         diff `shouldBe` deleting before
 
 
@@ -81,5 +79,13 @@ afterTerm = cata $ \ diff -> case diff of
   Patch patch -> (after patch >>= \ (In     b  r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum)
   Merge                             (In (_, b) r) -> termIn b <$> sequenceAlt r
 
+-- | Return the item from the after side of the patch.
+after :: Edit l r -> Maybe r
+after = edit (const Nothing) Just (\ _ b -> Just b)
+
+-- | Return the item from the before side of the patch.
+before :: Edit l r -> Maybe l
+before = edit Just (const Nothing) (\ a _ -> Just a)
+
 emptyAnnotation :: ()
 emptyAnnotation = ()

test/Integration/Spec.hs

@@ -39,7 +39,7 @@ testForExample = \case
       ("diffs " <> Path.toString diffOutput)
       (\ref new -> ["git", "diff", ref, new])
       (Path.toString diffOutput)
-      (BL.fromStrict <$> diffFilePaths ?session (Both fileA fileB))
+      (BL.fromStrict <$> diffFilePaths ?session fileA fileB)
   ParseExample{file, parseOutput} ->
     goldenVsStringDiff
       ("parses " <> Path.toString parseOutput)

test/Rendering/TOC/Spec.hs

@@ -8,7 +8,6 @@ import Data.Aeson hiding (defaultOptions)
 import Data.Bifunctor
 import Data.Diff
 import Data.Either (isRight)
-import Data.Patch
 import Data.Sum
 import Data.Term
 import Data.Text (Text)
@@ -37,9 +36,9 @@ spec = do
       \ term -> tableOfContentsBy (Just . termFAnnotation) (diffTerms term (term :: Term ListableSyntax ())) `shouldBe` []
 
     prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
-      \ p -> tableOfContentsBy (Just . termFAnnotation) (patch deleting inserting replacing p)
+      \ p -> tableOfContentsBy (Just . termFAnnotation) (edit deleting inserting comparing p)
       `shouldBe`
-      patch (fmap (Deleted,)) (fmap (Inserted,)) (\ as bs -> (Replaced, head bs) : fmap (Deleted,) (tail as) <> fmap (Inserted,) (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term ListableSyntax Int) (Term ListableSyntax Int)))
+      edit (fmap (Deleted,)) (fmap (Inserted,)) (\ as bs -> (Replaced, head bs) : fmap (Deleted,) (tail as) <> fmap (Inserted,) (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Edit (Term ListableSyntax Int) (Term ListableSyntax Int)))
 
     prop "produces changed entries for relevant nodes containing irrelevant patches" $
       \ diff -> do
@@ -53,7 +52,7 @@ spec = do
       diffTOC blankDiff `shouldBe` [ ]
 
     it "summarizes changed methods" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb"))
+      sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted
@@ -62,37 +61,37 @@ spec = do
         ]
 
     it "dedupes changes in same parent method" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js"))
+      sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ]
 
     it "dedupes similar methods" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js"))
+      sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ]
 
     it "summarizes Go methods with receivers with special formatting" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go"))
+      sourceBlobs <- blobsForPaths (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ]
 
     it "summarizes Ruby methods that start with two identifiers" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb"))
+      sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ]
 
     it "handles unicode characters in file" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb"))
+      sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe`
         [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ]
 
     it "properly slices source blob that starts with a newline and has multi-byte chars" $ do
-      sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js"))
+      sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")
       diff <- runTaskOrDie $ summarize sourceBlobs
       diff `shouldBe` []
 
@@ -135,22 +134,22 @@ spec = do
 
   describe "diff with ToCDiffRenderer'" $ do
     it "produces JSON output" $ do
-      blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb"))
+      blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
       runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"self.foo\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"ADDED\"},{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":6,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}]}]}\n" :: ByteString)
 
     it "produces JSON output if there are parse errors" $ do
-      blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb"))
+      blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
       runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":3}}}]}]}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
-      blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb"))
+      blobs <- blobsForPaths (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
       runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/lambda.A.rb -> test/fixtures/ruby/toc/lambda.B.rb\",\"language\":\"Ruby\"}]}\n" :: ByteString)
 
     it "summarizes Markdown headings" $ do
-      blobs <- blobsForPaths (Both (Path.relFile "markdown/toc/headings.A.md") (Path.relFile "markdown/toc/headings.B.md"))
+      blobs <- blobsForPaths (Path.relFile "markdown/toc/headings.A.md") (Path.relFile "markdown/toc/headings.B.md")
       output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs]))
       runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\",\"language\":\"Markdown\",\"changes\":[{\"category\":\"Heading 1\",\"term\":\"Introduction\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":3,\"column\":16}},\"changeType\":\"REMOVED\"},{\"category\":\"Heading 2\",\"term\":\"Two\",\"span\":{\"start\":{\"line\":5,\"column\":1},\"end\":{\"line\":7,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"span\":{\"start\":{\"line\":9,\"column\":1},\"end\":{\"line\":11,\"column\":10}},\"changeType\":\"ADDED\"},{\"category\":\"Heading 1\",\"term\":\"Final\",\"span\":{\"start\":{\"line\":13,\"column\":1},\"end\":{\"line\":14,\"column\":4}},\"changeType\":\"ADDED\"}]}]}\n" :: ByteString)
 
@@ -161,14 +160,14 @@ type Term' = Term ListableSyntax (Maybe Declaration)
 numTocSummaries :: Diff' -> Int
 numTocSummaries diff = length $ filter isRight (diffTOC diff)
 
--- Return a diff where body is inserted in the expressions of a function. The function is present in Both sides of the diff.
+-- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff.
 programWithChange :: Term' -> Diff'
 programWithChange body = merge (Nothing, Nothing) (inject [ function' ])
   where
     function' = merge (Just (Declaration Function "foo" lowerBound Ruby), Just (Declaration Function "foo" lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ]))))
     name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo")))
 
--- Return a diff where term is inserted in the program, below a function found on Both sides of the diff.
+-- Return a diff where term is inserted in the program, below a function found on both sides of the diff.
 programWithChangeOutsideFunction :: Term' -> Diff'
 programWithChangeOutsideFunction term = merge (Nothing, Nothing) (inject [ function', term' ])
   where
@@ -183,7 +182,7 @@ programWithDelete :: Text -> Term' -> Diff'
 programWithDelete name body = programOf $ deleting (functionOf name body)
 
 programWithReplace :: Text -> Term' -> Diff'
-programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body)
+programWithReplace name body = programOf $ comparing (functionOf name body) (functionOf (name <> "2") body)
 
 programOf :: Diff' -> Diff'
 programOf diff = merge (Nothing, Nothing) (inject [ diff ])
@@ -208,8 +207,9 @@ isMethodOrFunction a
   | any isJust (foldMap (:[]) a)                       = True
   | otherwise                                          = False
 
-blobsForPaths :: Both Path.RelFile -> IO BlobPair
-blobsForPaths = readFilePathPair . fmap (Path.relDir "test/fixtures" </>)
+blobsForPaths :: Path.RelFile -> Path.RelFile -> IO BlobPair
+blobsForPaths p1 p2 = readFilePathPair (prefix p1) (prefix p2) where
+  prefix = (Path.relDir "test/fixtures" </>)
 
 blankDiff :: Diff'
 blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ])

test/Semantic/CLI/Spec.hs

@@ -34,7 +34,7 @@ renderDiff ref new = unsafePerformIO $ do
     else ["git", "diff", ref, new]
 {-# NOINLINE renderDiff #-}
 
-testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile) -> TestTree
+testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile) -> TestTree
 testForDiffFixture (diffRenderer, runDiff, files, expected) =
   goldenVsStringDiff
     ("diff fixture renders to " <> diffRenderer <> " " <> show files)
@@ -65,12 +65,12 @@ parseFixtures =
         prefix = Path.relDir "test/fixtures/cli"
         run = runReader (PerLanguageModes ALaCarte)
 
-diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile)]
+diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile)]
 diffFixtures =
   [ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
   , ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")
   , ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json")
   , ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin")
   ]
-  where pathMode = [Both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby) (File "test/fixtures/ruby/corpus/method-declaration.B.rb"  Ruby)]
+  where pathMode = [(File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby, File "test/fixtures/ruby/corpus/method-declaration.B.rb"  Ruby)]
         prefix = Path.relDir "test/fixtures/cli"

test/Semantic/IO/Spec.hs

@@ -4,86 +4,12 @@ module Semantic.IO.Spec (spec) where
 
 import Prelude hiding (readFile)
 
-import           Control.Monad.IO.Class
-import           Data.List
-import           Data.String
-import qualified Data.Text as Text
-import           System.Directory
-import           System.IO.Temp
-
 import           Data.Blob
 import           Data.Handle
-import qualified Semantic.Git as Git
-import           Shelly (cd, run_, shelly, silently, touchfile, writefile)
-import qualified Source.Source as Source
 import           SpecHelpers
-import           System.Path ((</>))
-import qualified System.Path as Path
-
-
-makeGitRepo :: FilePath -> IO ()
-makeGitRepo dir = shelly . silently $ do
-  cd (fromString dir)
-  let git = run_ "git"
-  git ["init"]
-  touchfile "bar.py"
-  writefile "日本語.rb" "# coding: utf-8\n日本語 = 'hello'"
-  git ["add", "日本語.rb", "bar.py"]
-  git ["config", "user.name", "'Test'"]
-  git ["config", "user.email", "'test@test.test'"]
-  git ["commit", "-am", "'test commit'"]
 
 spec :: Spec
 spec = do
-  describe "catFile" $ do
-    hasGit <- runIO $ isJust <$> findExecutable "git"
-    when hasGit . it "should not corrupt the output of files with UTF-8 identifiers" $ do
-      result <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
-        makeGitRepo dir
-        trees <- Git.lsTree (dir <> "/.git") (Git.OID "HEAD")
-        Just it <- pure $ find (\p -> "日本語" `isInfixOf` Git.treeEntryPath p) trees
-        Git.catFile (dir <> "/.git") (Git.treeEntryOid it)
-      Source.toText result `shouldSatisfy` ("日本語" `Text.isInfixOf`)
-
-  describe "lsTree" $ do
-    hasGit <- runIO $ isJust <$> findExecutable "git"
-    when hasGit . it "should read all tree entries from a repo" $ do
-      items <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
-        makeGitRepo dir
-        Git.lsTree dir (Git.OID "HEAD")
-
-      length items `shouldBe` 2
-
-  describe "readBlobsFromGitRepo" $ do
-    hasGit <- runIO $ isJust <$> findExecutable "git"
-    when hasGit . it "should read from a git directory" $ do
-      -- This temporary directory will be cleaned after use.
-      blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
-        makeGitRepo dir
-        readBlobsFromGitRepoPath (Path.absDir dir </> Path.relDir ".git") (Git.OID "HEAD") [] []
-      let files = sortOn fileLanguage (blobFile <$> blobs)
-      files `shouldBe` [ File "bar.py" Python
-                       , File "日本語.rb" Ruby
-                       ]
-
-    when hasGit . it "should read from a git directory with --only" $ do
-      -- This temporary directory will be cleaned after use.
-      blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
-        let pdir = Path.absDir dir
-        makeGitRepo dir
-        readBlobsFromGitRepoPath (pdir </> Path.relDir ".git") (Git.OID "HEAD") [] [Path.relFile "日本語.rb"]
-      let files = sortOn fileLanguage (blobFile <$> blobs)
-      files `shouldBe` [ File "日本語.rb" Ruby ]
-
-    when hasGit . it "should read from a git directory with --exclude" $ do
-      -- This temporary directory will be cleaned after use.
-      blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
-        makeGitRepo dir
-
-        readBlobsFromGitRepoPath (Path.absDir dir </> Path.relDir ".git") (Git.OID "HEAD") [Path.relFile "日本語.rb"] []
-      let files = sortOn fileLanguage (blobFile <$> blobs)
-      files `shouldBe` [ File "bar.py" Python ]
-
   describe "readFile" $ do
     it "returns a blob for extant files" $ do
       Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
@@ -97,34 +23,34 @@ spec = do
     let b = sourceBlob "method.rb" Ruby "def bar(x); end"
     it "returns blobs for valid JSON encoded diff input" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
-      blobs `shouldBe` [Diffing a b]
+      blobs `shouldBe` [Compare a b]
 
     it "returns blobs when there's no before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json"
-      blobs `shouldBe` [Inserting b]
+      blobs `shouldBe` [Insert b]
 
     it "returns blobs when there's null before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json"
-      blobs `shouldBe` [Inserting b]
+      blobs `shouldBe` [Insert b]
 
     it "returns blobs when there's no after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json"
-      blobs `shouldBe` [Deleting a]
+      blobs `shouldBe` [Delete a]
 
     it "returns blobs when there's null after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json"
-      blobs `shouldBe` [Deleting a]
+      blobs `shouldBe` [Delete a]
 
 
     it "returns blobs for unsupported language" $ do
       h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json"
       blobs <- readBlobPairsFromHandle h
       let b' = sourceBlob "test.kt" Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
-      blobs `shouldBe` [Inserting b']
+      blobs `shouldBe` [Insert b']
 
     it "detects language based on filepath for empty language" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json"
-      blobs `shouldBe` [Diffing a b]
+      blobs `shouldBe` [Compare a b]
 
     it "throws on blank input" $ do
       h <- openFileForReading "test/fixtures/cli/blank.json"

test/Semantic/Spec.hs

@@ -6,7 +6,6 @@ import SpecHelpers
 
 import Data.Blob (NoLanguageForBlob (..))
 import Semantic.Api hiding (Blob)
-import Semantic.Git
 
  -- we need some lenses here, oof
 setBlobLanguage :: Language -> Blob -> Blob
@@ -15,6 +14,8 @@ setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }}
 spec :: Spec
 spec = do
   describe "parseBlob" $ do
+    let methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty
+
     it "returns error if given an unknown language (json)" $ do
       output <- fmap runBuilder . runTaskOrDie . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ]
       output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n"
@@ -28,27 +29,3 @@ spec = do
     it "renders with the specified renderer" $ do
       output <- fmap runBuilder . runTaskOrDie . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression [methodsBlob]
       output `shouldBe` "(Statements\n  (Method\n    (Empty)\n    (Identifier)\n    (Statements)))\n"
-
-  describe "git ls-tree parsing" $ do
-    it "parses a git output string" $ do
-      let input = "100644 tree abcdef\t/this/is/the/path"
-      let expected = Right $ TreeEntry NormalMode TreeObject (OID "abcdef") "/this/is/the/path"
-      parseEntry input `shouldBe` expected
-
-    it "allows whitespace in the path" $ do
-      let input = "100644 tree 12345\t/this\n/is\t/the /path\r"
-      let expected = Right $ TreeEntry NormalMode TreeObject (OID "12345") "/this\n/is\t/the /path\r"
-      parseEntry input `shouldBe` expected
-
-    it "parses many outputs separated by \\NUL" $ do
-      let input = "100644 tree abcdef\t/this/is/the/path\NUL120000 blob 17776\t/dev/urandom\NUL\n"
-      let expected = [ TreeEntry NormalMode TreeObject (OID "abcdef") "/this/is/the/path", TreeEntry SymlinkMode BlobObject (OID "17776") "/dev/urandom"]
-      parseEntries input `shouldBe` expected
-
-    it "parses submodules and other types" $ do
-      let input = "160000 commit 50865e8895c54037bf06c4c1691aa925d030a59d\tgemoji"
-      let expected = Right $ TreeEntry OtherMode OtherObjectType (OID "50865e8895c54037bf06c4c1691aa925d030a59d") "gemoji"
-      parseEntry input `shouldBe` expected
-
-  where
-    methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty

test/SpecHelpers.hs

@@ -60,7 +60,7 @@ import Source.Span as X hiding (HasSpan(..), start, end, point)
 import Debug.Trace as X (traceShowM, traceM)
 
 import Data.ByteString as X (ByteString)
-import Data.Functor.Both as X (Both (Both), runBothWith)
+import Data.Edit as X
 import Data.Maybe as X
 import Data.Monoid as X (Monoid(..), First(..), Last(..))
 import Data.Semigroup as X (Semigroup(..))
@@ -87,11 +87,11 @@ instance IsString Name where
   fromString = X.name . fromString
 
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
-diffFilePaths :: TaskSession -> Both Path.RelFile -> IO ByteString
-diffFilePaths session paths
-  = readFilePathPair paths
-    >>= runTask session . runParse (configTreeSitterParseTimeout (config session)) . parseDiffBuilder @[] DiffSExpression . pure
-    >>= either (die . displayException) (pure . runBuilder)
+diffFilePaths :: TaskSession -> Path.RelFile -> Path.RelFile -> IO ByteString
+diffFilePaths session p1 p2 = do
+  blobs <- readFilePathPair p1 p2
+  builder <- runTask session (runParse (configTreeSitterParseTimeout (config session)) (parseDiffBuilder DiffSExpression [ blobs ]))
+  either (die . displayException) (pure . runBuilder) builder
 
 -- | Returns an s-expression parse tree for the specified path.
 parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
@@ -104,9 +104,8 @@ runParseWithConfig :: (Carrier sig m, Member (Reader Config) sig) => ParseC m a
 runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task
 
 -- | Read two files to a BlobPair.
-readFilePathPair :: Both Path.RelFile -> IO BlobPair
-readFilePathPair paths = let paths' = fmap fileForTypedPath paths in
-                     runBothWith readFilePair paths'
+readFilePathPair :: Path.RelFile -> Path.RelFile -> IO BlobPair
+readFilePathPair p1 p2 = readFilePair (fileForTypedPath p1) (fileForTypedPath p2)
 
 parseTestFile :: Parser term -> Path.RelFile -> IO (Blob, term)
 parseTestFile parser path = runTaskOrDie $ do