Merge pull request #1456 from github/bidistribute

Model blob pairs as These instead of Both

src/Assigning/Assignment.hs

@@ -218,7 +218,7 @@ nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol))
 
 
 firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar]
-firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of
+firstSet = iterFreer (\ _ (Tracing _ assignment) -> case assignment of
   Choose table _ _ -> Table.tableAddresses table
   Label child _ -> firstSet child
   _ -> []) . ([] <$)
@@ -245,11 +245,11 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
         go assignment = iterFreer run ((pure .) . (,) <$> assignment)
         {-# INLINE go #-}
 
-        run :: Tracing (AssignmentF ast grammar) x
-            -> (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar))
+        run :: (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar))
+            -> Tracing (AssignmentF ast grammar) x
             -> State ast grammar
             -> Either (Error (Either String grammar)) (result, State ast grammar)
-        run t yield initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
+        run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
           where atNode (Term (In node f)) = case runTracing t of
                   Location -> yield (nodeLocation node) state
                   CurrentNode -> yield (In node (() <$ f)) state
@@ -367,7 +367,7 @@ instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error
   throwError err = fail (show err)
 
   catchError :: HasCallStack => Assignment ast grammar a -> (Error (Either String grammar) -> Assignment ast grammar a) -> Assignment ast grammar a
-  catchError rule handler = iterFreer (\ (Tracing cs assignment) continue -> case assignment of
+  catchError rule handler = iterFreer (\ continue (Tracing cs assignment) -> case assignment of
     Choose choices atEnd Nothing -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler)) `Then` return
     Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` return
     _ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule)

src/Data/Blob.hs

@@ -1,56 +1,62 @@
 module Data.Blob
 ( Blob(..)
-, BlobKind(..)
-, modeToDigits
-, defaultPlainBlob
-, emptyBlob
 , nullBlob
-, blobExists
 , sourceBlob
-, nullOid
+, BlobPair
+, These(..)
+, blobPairDiffing
+, blobPairInserting
+, blobPairDeleting
+, languageForBlobPair
+, languageTagForBlobPair
+, pathForBlobPair
 ) where
 
-import Data.ByteString.Char8 (ByteString, pack)
+import Data.Bifunctor.Join
 import Data.Language
-import Data.Maybe (isJust)
+import Data.These
 import Data.Source as Source
-import Data.Word
-import Numeric
 
--- | The source, oid, path, and Maybe BlobKind of a blob.
+
+-- | The source, path, and language of a blob.
 data Blob = Blob
   { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
-  , blobOid :: ByteString -- ^ The Git object ID (SHA-1) of the blob.
   , blobPath :: FilePath -- ^ The file path to the blob.
-  , blobKind :: Maybe BlobKind -- ^ The kind of blob, Nothing denotes a blob that doesn't exist (e.g. on one side of a diff for adding a new file or deleting a file).
   , blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet.
   }
   deriving (Show, Eq)
 
--- | The kind and file mode of a 'Blob'.
-data BlobKind = PlainBlob Word32 | ExecutableBlob Word32 | SymlinkBlob Word32
-  deriving (Show, Eq)
-
-modeToDigits :: BlobKind -> ByteString
-modeToDigits (PlainBlob mode) = pack $ showOct mode ""
-modeToDigits (ExecutableBlob mode) = pack $ showOct mode ""
-modeToDigits (SymlinkBlob mode) = pack $ showOct mode ""
-
--- | The default plain blob mode
-defaultPlainBlob :: BlobKind
-defaultPlainBlob = PlainBlob 0o100644
-
-emptyBlob :: FilePath -> Blob
-emptyBlob filepath = Blob mempty nullOid filepath Nothing Nothing
-
 nullBlob :: Blob -> Bool
-nullBlob Blob{..} = blobOid == nullOid || nullSource blobSource
-
-blobExists :: Blob -> Bool
-blobExists Blob{..} = isJust blobKind
+nullBlob Blob{..} = nullSource blobSource
 
 sourceBlob :: FilePath -> Maybe Language -> Source -> Blob
-sourceBlob filepath language source = Blob source nullOid filepath (Just defaultPlainBlob) language
+sourceBlob filepath language source = Blob source filepath language
 
-nullOid :: ByteString
-nullOid = "0000000000000000000000000000000000000000"
+
+-- | 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.
+type BlobPair = Join These Blob
+
+
+blobPairDiffing :: Blob -> Blob -> BlobPair
+blobPairDiffing a b = Join (These a b)
+
+blobPairInserting :: Blob -> BlobPair
+blobPairInserting = Join . That
+
+blobPairDeleting :: Blob -> BlobPair
+blobPairDeleting = Join . This
+
+languageForBlobPair :: BlobPair -> Maybe Language
+languageForBlobPair (Join (This Blob{..})) = blobLanguage
+languageForBlobPair (Join (That Blob{..})) = blobLanguage
+languageForBlobPair (Join (These _ Blob{..})) = blobLanguage
+
+pathForBlobPair :: BlobPair -> FilePath
+pathForBlobPair (Join (This Blob{..})) = blobPath
+pathForBlobPair (Join (That Blob{..})) = blobPath
+pathForBlobPair (Join (These _ Blob{..})) = blobPath
+
+languageTagForBlobPair :: BlobPair -> [(String, String)]
+languageTagForBlobPair pair = maybe [] showLanguage (languageForBlobPair pair)
+  where showLanguage = pure . (,) "language" . show

src/Data/Error.hs

@@ -39,7 +39,7 @@ type Colourize = Bool
 formatError :: IncludeSource -> Colourize -> Blob -> Error String -> String
 formatError includeSource colourize Blob{..} Error{..}
   = ($ "")
-  $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan (maybe Nothing (const (Just blobPath)) blobKind) errorSpan . showString ": ")
+  $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan (Just blobPath) errorSpan . showString ": ")
   . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n'
   . (if includeSource
     then showString (unpack context) . (if "\n" `isSuffixOf` context then id else showChar '\n')

src/Diffing/Interpreter.hs

@@ -75,7 +75,7 @@ runAlgorithm comparable eqTerms = go
              (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))
              result
            -> m result
-        go = iterFreerA (\ step yield -> case step of
+        go = iterFreerA (\ yield step -> case step of
           Diffing.Algorithm.Diff t1 t2 -> go (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
           Linear (Term (In ann1 f1)) (Term (In ann2 f2)) -> merge (ann1, ann2) <$> galignWith (go . diffThese) f1 f2 >>= yield
           RWS as bs -> traverse (go . diffThese) (rws comparable eqTerms as bs) >>= yield

src/Rendering/JSON.hs

@@ -4,26 +4,20 @@ module Rendering.JSON
 ) where
 
 import Data.Aeson (ToJSON, toJSON, object, (.=))
-import Data.Aeson as A hiding (json)
+import Data.Aeson as A
 import Data.Blob
-import Data.Foldable (toList)
-import Data.Functor.Both (Both)
+import Data.Bifoldable (biList)
+import Data.Bifunctor.Join
 import Data.Language
 import qualified Data.Map as Map
 import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8)
 import GHC.Generics
 
---
--- Diffs
---
-
 -- | Render a diff to a string representing its JSON.
-renderJSONDiff :: ToJSON a => Both Blob -> a -> Map.Map Text Value
+renderJSONDiff :: ToJSON a => BlobPair -> a -> Map.Map Text Value
 renderJSONDiff blobs diff = Map.fromList
   [ ("diff", toJSON diff)
-  , ("oids", toJSON (decodeUtf8 . blobOid <$> toList blobs))
-  , ("paths", toJSON (blobPath <$> toList blobs))
+  , ("paths", toJSON (blobPath <$> (biList . runJoin) blobs))
   ]
 
 data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a }
@@ -32,5 +26,6 @@ data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileC
 instance ToJSON a => ToJSON (File a) where
   toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ]
 
+-- | Render a term to a string representing its JSON.
 renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
 renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage

src/Rendering/TOC.hs

@@ -21,17 +21,17 @@ import Data.Aeson
 import Data.Align (bicrosswalk)
 import Data.Bifoldable (bifoldMap)
 import Data.Bifunctor (bimap)
+import Data.Bifunctor.Join
 import Data.Blob
 import Data.ByteString.Lazy (toStrict)
 import Data.Diff
 import Data.Foldable (fold, foldl')
-import Data.Functor.Both hiding (fst, snd)
 import Data.Functor.Foldable (cata)
 import Data.Function (on)
 import Data.Language as Language
 import Data.List (sortOn)
 import qualified Data.List as List
-import qualified Data.Map as Map hiding (null)
+import qualified Data.Map as Map
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Output
 import Data.Patch
@@ -160,15 +160,15 @@ recordSummary changeText record = case getDeclaration record of
     formatIdentifier (MethodDeclaration identifier _ _                  (Just receiver)) = receiver <> "." <> identifier
     formatIdentifier declaration = declarationIdentifier declaration
 
-renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries
+renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => BlobPair -> Diff f (Record fields) (Record fields) -> Summaries
 renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
   where toMap [] = mempty
         toMap as = Map.singleton summaryKey (toJSON <$> as)
-        summaryKey = T.pack $ case runJoin (blobPath <$> blobs) of
-          (before, after) | null before -> after
-                          | null after -> before
-                          | before == after -> after
-                          | otherwise -> before <> " -> " <> after
+        summaryKey = T.pack $ case bimap blobPath blobPath (runJoin blobs) of
+           This before -> before
+           That after -> after
+           These before after | before == after -> after
+                              | otherwise -> before <> " -> " <> after
 
 diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [TOCSummary]
 diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration

src/Semantic.hs

@@ -16,10 +16,10 @@ import Control.Monad ((>=>), guard)
 import Control.Monad.Error.Class
 import Data.Align.Generic
 import Data.Bifoldable
+import Data.Bifunctor.Join
 import Data.Blob
 import Data.ByteString (ByteString)
 import Data.Diff
-import Data.Functor.Both as Both
 import Data.Functor.Classes
 import Data.JSON.Fields
 import qualified Data.Language as Language
@@ -45,7 +45,7 @@ import Semantic.Task as Task
 --   - Easy to consume this interface from other application (e.g a cmdline or web server app).
 
 parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
-parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . filter blobExists
+parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer)
 
 -- | A task to parse a 'Blob' and render the resulting 'Term'.
 parseBlob :: TermRenderer output -> Blob -> Task output
@@ -70,11 +70,11 @@ data NoParserForLanguage = NoParserForLanguage FilePath (Maybe Language.Language
   deriving (Eq, Exception, Ord, Show, Typeable)
 
 
-diffBlobPairs :: Output output => DiffRenderer output -> [Both Blob] -> Task ByteString
-diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair renderer) . filter (any blobExists)
+diffBlobPairs :: Output output => DiffRenderer output -> [BlobPair] -> Task ByteString
+diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair renderer)
 
 -- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
-diffBlobPair :: DiffRenderer output -> Both Blob -> Task output
+diffBlobPair :: DiffRenderer output -> BlobPair -> Task output
 diffBlobPair renderer blobs
   | Just (SomeParser parser) <- effectiveLanguage >>= qualify >>= someParser (Proxy :: Proxy '[ConstructorName, IdentifierName, Diffable, Eq1, GAlign, HasDeclaration, Show1, ToJSONFields1, Traversable])
   = case renderer of
@@ -91,10 +91,8 @@ diffBlobPair renderer blobs
     SExpressionDiffRenderer -> run (          parse parser      >=> pure . fmap keepCategory)                 diffSyntaxTerms (const renderSExpressionDiff)
 
   | otherwise = throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage))
-  where (effectivePath, effectiveLanguage) = case runJoin blobs of
-          (Blob { blobLanguage = Just lang, blobPath = path }, _) -> (path, Just lang)
-          (_, Blob { blobLanguage = Just lang, blobPath = path }) -> (path, Just lang)
-          (Blob { blobPath = path }, _)                           -> (path, Nothing)
+  where effectiveLanguage = languageForBlobPair blobs
+        effectivePath = pathForBlobPair blobs
 
         qualify language | OldToCDiffRenderer <- renderer = guard (language `elem` aLaCarteLanguages) *> Just language
                          | otherwise                      =                                              Just language
@@ -108,24 +106,21 @@ diffBlobPair renderer blobs
             , Language.TypeScript
             ]
 
-        run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Both Blob -> Diff syntax ann ann -> output) -> Task output
+        run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Join These Blob -> Diff syntax ann ann -> output) -> Task output
         run parse diff renderer = do
-          terms <- distributeFor blobs parse
+          terms <- bidistributeFor (runJoin blobs) parse parse
           time "diff" languageTag $ do
-            diff <- runBothWith (diffTermPair blobs diff) terms
+            diff <- diffTermPair diff terms
             writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
             render (renderer blobs) diff
           where
-            showLanguage = pure . (,) "language" . show
-            languageTag = let (a, b) = runJoin blobs
-                          in maybe (maybe [] showLanguage (blobLanguage b)) showLanguage (blobLanguage a)
+            languageTag = languageTagForBlobPair blobs
 
--- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
-diffTermPair :: Functor syntax => Both Blob -> Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
-diffTermPair blobs differ t1 t2 = case runJoin (blobExists <$> blobs) of
-  (True, False) -> pure (deleting t1)
-  (False, True) -> pure (inserting t2)
-  _ -> diff differ t1 t2
+-- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
+diffTermPair :: Functor syntax => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Task (Diff syntax ann1 ann2)
+diffTermPair _      (This  t1   ) = pure (deleting t1)
+diffTermPair _      (That     t2) = pure (inserting t2)
+diffTermPair differ (These t1 t2) = diff differ t1 t2
 
 keepCategory :: HasField fields Category => Record fields -> Record '[Category]
 keepCategory = (:. Nil) . category

src/Semantic/IO.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-}
 module Semantic.IO
 ( readFile
+, readFilePair
 , isDirectory
 , readBlobPairsFromHandle
 , readBlobsFromHandle
@@ -9,7 +10,6 @@ module Semantic.IO
 , languageForFilePath
 ) where
 
-import Control.Exception (catch, IOException)
 import Control.Monad.IO.Class
 import Data.Aeson
 import qualified Data.Blob as Blob
@@ -21,6 +21,7 @@ import Data.Source
 import Data.String
 import Data.Text
 import Data.These
+import Data.Traversable
 import GHC.Generics
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
@@ -33,11 +34,21 @@ import System.Directory (doesDirectoryExist)
 import Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
-readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob
-readFile path@"/dev/null" _ = pure (Blob.emptyBlob path)
+readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob)
+readFile "/dev/null" _ = pure Nothing
 readFile path language = do
-  raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe B.ByteString))
-  pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw)
+  raw <- liftIO $ (Just <$> B.readFile path)
+  pure $ Blob.sourceBlob path language . fromBytes <$> raw
+
+readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair
+readFilePair a b = do
+  before <- uncurry readFile a
+  after <- uncurry readFile b
+  case (before, after) of
+    (Just a, Nothing) -> pure (Join (This a))
+    (Nothing, Just b) -> pure (Join (That b))
+    (Just a, Just b) -> pure (Join (These a b))
+    _ -> fail "expected file pair with content on at least one side"
 
 isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path) >>= pure
@@ -47,12 +58,12 @@ languageForFilePath :: FilePath -> Maybe Language
 languageForFilePath = languageForType . takeExtension
 
 -- | Read JSON encoded blob pairs from a handle.
-readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob]
+readBlobPairsFromHandle :: MonadIO m => Handle -> m [Blob.BlobPair]
 readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
   where
+    toBlobPairs :: BlobDiff -> [Blob.BlobPair]
     toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
-    toBlobPair blobs = Join (fromThese empty empty (runJoin (toBlob <$> blobs)))
-      where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs)))
+    toBlobPair blobs = toBlob <$> blobs
 
 -- | Read JSON encoded blobs from a handle.
 readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
@@ -60,13 +71,14 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle
   where toBlobs BlobParse{..} = fmap toBlob blobs
 
 readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
-readBlobsFromPaths = traverse (uncurry Semantic.IO.readFile)
+readBlobsFromPaths files = traverse (uncurry Semantic.IO.readFile) files >>= pure . catMaybes
 
 readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
 readBlobsFromDir path = do
   paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
   let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths
-  traverse (uncurry readFile) paths'
+  blobs <- traverse (uncurry readFile) paths'
+  pure (catMaybes blobs)
 
 readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
 readFromHandle h = do

src/Semantic/Task.hs

@@ -17,6 +17,8 @@ module Semantic.Task
 , distribute
 , distributeFor
 , distributeFoldMap
+, bidistribute
+, bidistributeFor
 , defaultOptions
 , configureOptionsForHandle
 , terminalFormatter
@@ -41,6 +43,8 @@ import Data.Diff
 import qualified Data.Error as Error
 import Data.Foldable (fold, for_)
 import Data.Functor.Both as Both hiding (snd)
+import Data.Bitraversable
+import Data.Bifunctor
 import Data.Functor.Foldable (cata)
 import Data.Language
 import Data.Record
@@ -61,7 +65,7 @@ import Semantic.Queue
 
 data TaskF output where
   ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
-  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
+  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [BlobPair]
   WriteToOutput :: Either Handle FilePath -> B.ByteString -> TaskF ()
   WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
   WriteStat :: Stat -> TaskF ()
@@ -71,6 +75,7 @@ data TaskF output where
   Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2)
   Render :: Renderer input output -> input -> TaskF output
   Distribute :: Traversable t => t (Task output) -> TaskF (t output)
+  Bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> TaskF (t output1 output2)
 
   -- | For MonadIO.
   LiftIO :: IO a -> TaskF a
@@ -93,7 +98,7 @@ readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob]
 readBlobs from = ReadBlobs from `Then` return
 
 -- | 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 :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob]
+readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [BlobPair]
 readBlobPairs from = ReadBlobPairs from `Then` return
 
 -- | A 'Task' which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
@@ -134,12 +139,24 @@ render renderer input = Render renderer input `Then` return
 distribute :: Traversable t => t (Task output) -> Task (t output)
 distribute tasks = Distribute tasks `Then` return
 
+-- | Distribute a 'Bitraversable' container of 'Task's over the available cores (i.e. execute them concurrently), collecting their results.
+--
+--   This is a concurrent analogue of 'bisequenceA'.
+bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> Task (t output1 output2)
+bidistribute tasks = Bidistribute tasks `Then` return
+
 -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
 --
 --   This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
 distributeFor :: Traversable t => t a -> (a -> Task output) -> Task (t output)
 distributeFor inputs toTask = distribute (fmap toTask inputs)
 
+-- | Distribute the application of a function to each element of a 'Bitraversable' container of inputs over the available cores (i.e. perform the functions concurrently for each element), collecting the results.
+--
+--   This is a concurrent analogue of 'bifor' or 'bitraverse' (with the arguments flipped).
+bidistributeFor :: Bitraversable t => t a b -> (a -> Task output1) -> (b -> Task output2) -> Task (t output1 output2)
+bidistributeFor inputs toTask1 toTask2 = bidistribute (bimap toTask1 toTask2 inputs)
+
 -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value.
 --
 --   This is a concurrent analogue of 'foldMap'.
@@ -176,11 +193,11 @@ runTaskWithOptions options task = do
     run options logger statter = go
       where
         go :: Task a -> IO (Either SomeException a)
-        go = iterFreerA (\ task yield -> case task of
+        go = iterFreerA (\ yield task -> case task of
           ReadBlobs (Left handle) -> (IO.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException)
           ReadBlobs (Right paths@[(path, Nothing)]) -> (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException)
           ReadBlobs (Right paths) -> (IO.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException)
-          ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (traverse (uncurry IO.readFile))) source >>= yield) `catchError` (pure . Left . toException)
+          ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (runBothWith IO.readFilePair)) source >>= yield) `catchError` (pure . Left . toException)
           WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
           WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield
           WriteStat stat -> queue statter stat >>= yield
@@ -190,6 +207,7 @@ runTaskWithOptions options task = do
           Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) >>= yield
           Render renderer input -> pure (renderer input) >>= yield
           Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
+          Bidistribute tasks -> Async.runConcurrently (bitraverse (Async.Concurrently . go) (Async.Concurrently . go) tasks) >>= either (pure . Left) yield . bisequenceA . withStrategy (parBitraversable (parTraversable rseq) (parTraversable rseq))
           LiftIO action -> action >>= yield
           Throw err -> pure (Left err)
           Catch during handler -> do
@@ -198,6 +216,9 @@ runTaskWithOptions options task = do
               Left err -> go (handler err) >>= either (pure . Left) yield
               Right a -> yield a) . fmap Right
 
+        parBitraversable :: Bitraversable t => Strategy a -> Strategy b -> Strategy (t a b)
+        parBitraversable strat1 strat2 = bitraverse (rparWith strat1) (rparWith strat2)
+
 runParser :: Options -> Blob -> Parser term -> Task term
 runParser Options{..} blob@Blob{..} = go
   where

src/Semantic/Util.hs

@@ -5,10 +5,11 @@ module Semantic.Util where
 import Analysis.Declaration
 import Control.Monad.IO.Class
 import Data.Align.Generic
+import Data.Maybe
 import Data.Blob
 import Data.Diff
-import Data.Functor.Both
 import Data.Functor.Classes
+import Data.Bifunctor.Join
 import Data.Range
 import Data.Record
 import Data.Span
@@ -21,7 +22,7 @@ import Semantic.IO as IO
 import Semantic.Task
 
 file :: MonadIO m => FilePath -> m Blob
-file path = IO.readFile path (languageForFilePath path)
+file path = IO.readFile path (languageForFilePath path) >>= pure . fromJust
 
 diffWithParser :: (HasField fields Data.Span.Span,
                    HasField fields Range,
@@ -29,12 +30,13 @@ diffWithParser :: (HasField fields Data.Span.Span,
                    Traversable syntax, Functor syntax,
                    Foldable syntax, Diffable syntax,
                    GAlign syntax, HasDeclaration syntax)
-                  => Parser (Term syntax (Record fields))
-                  -> Both Blob
+                  =>
+                  Parser (Term syntax (Record fields))
+                  -> BlobPair
                   -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
 diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
   where
-    run parse sourceBlobs = distributeFor sourceBlobs parse >>= runBothWith (diffTermPair sourceBlobs diffTerms)
+    run parse blobs = bidistributeFor (runJoin blobs) parse parse >>= diffTermPair diffTerms
 
 diffBlobWithParser :: (HasField fields Data.Span.Span,
                    HasField fields Range,

test/Rendering/TOC/Spec.hs

@@ -240,8 +240,8 @@ isMethodOrFunction a = case unTerm a of
   (a `In` _) | getField a == C.SingletonMethod -> True
   _ -> False
 
-blobsForPaths :: Both FilePath -> IO (Both Blob)
-blobsForPaths = traverse (readFile . ("test/fixtures/toc/" <>))
+blobsForPaths :: Both FilePath -> IO BlobPair
+blobsForPaths = readFilePair . fmap ("test/fixtures/toc/" <>)
 
 sourceSpanBetween :: (Int, Int) -> (Int, Int) -> Span
 sourceSpanBetween (s1, e1) (s2, e2) = Span (Pos s1 e1) (Pos s2 e2)
@@ -253,4 +253,4 @@ blankDiff = merge (arrayInfo, arrayInfo) (Indexed [ inserting (Term $ literalInf
     literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil
 
 blankDiffBlobs :: Both Blob
-blankDiffBlobs = both (Blob (fromText "[]") nullOid "a.js" (Just defaultPlainBlob) (Just TypeScript)) (Blob (fromText "[a]") nullOid "b.js" (Just defaultPlainBlob) (Just TypeScript))
+blankDiffBlobs = both (Blob (fromText "[]") "a.js" (Just TypeScript)) (Blob (fromText "[a]") "b.js" (Just TypeScript))

test/Semantic/CLI/Spec.hs

@@ -38,7 +38,6 @@ parseFixtures =
   , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput)
   , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput')
   , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput)
-  , (SomeRenderer JSONTermRenderer, Right [("not-a-file.rb", Just Ruby)], emptyJsonParseTreeOutput)
   , (SomeRenderer ToCTermRenderer, Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tocOutput)
   ]
   where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
@@ -59,6 +58,6 @@ diffFixtures =
   ]
   where pathMode = Right [both ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)]
 
-        jsonOutput = "{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"oids\":[\"0000000000000000000000000000000000000000\",\"0000000000000000000000000000000000000000\"],\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n"
+        jsonOutput = "{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n"
         sExpressionOutput = "(Program\n  (Method\n    (Empty)\n  { (Identifier)\n  ->(Identifier) }\n  {+(Identifier)+}\n    (\n    {+(Identifier)+})))\n"
         tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"

test/Semantic/IO/Spec.hs

@@ -9,53 +9,52 @@ import Prelude hiding (readFile)
 import Semantic.IO
 import System.Exit (ExitCode(..))
 import System.IO (IOMode(..), openFile)
-import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
+import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall, anyIOException)
 import Test.Hspec.Expectations.Pretty
 
 spec :: Spec
 spec = parallel $ do
   describe "readFile" $ do
     it "returns a blob for extant files" $ do
-      blob <- readFile "semantic-diff.cabal" Nothing
+      Just blob <- readFile "semantic-diff.cabal" Nothing
       blobPath blob `shouldBe` "semantic-diff.cabal"
 
-    it "returns a nullBlob for absent files" $ do
-      blob <- readFile "this file should not exist" Nothing
-      nullBlob blob `shouldBe` True
+    it "throws for absent files" $ do
+      readFile "this file should not exist" Nothing `shouldThrow` anyIOException
 
   describe "readBlobPairsFromHandle" $ do
     let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
     let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end"
     it "returns blobs for valid JSON encoded diff input" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff.json"
-      blobs `shouldBe` [both a b]
+      blobs `shouldBe` [blobPairDiffing a b]
 
     it "returns blobs when there's no before" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-no-before.json"
-      blobs `shouldBe` [both (emptyBlob "method.rb") b]
+      blobs `shouldBe` [blobPairInserting b]
 
     it "returns blobs when there's null before" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-null-before.json"
-      blobs `shouldBe` [both (emptyBlob "method.rb") b]
+      blobs `shouldBe` [blobPairInserting b]
 
     it "returns blobs when there's no after" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-no-after.json"
-      blobs `shouldBe` [both a (emptyBlob "method.rb")]
+      blobs `shouldBe` [blobPairDeleting a]
 
     it "returns blobs when there's null after" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-null-after.json"
-      blobs `shouldBe` [both a (emptyBlob "method.rb")]
+      blobs `shouldBe` [blobPairDeleting a]
 
 
     it "returns blobs for unsupported language" $ do
       h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode
       blobs <- readBlobPairsFromHandle h
       let b' = sourceBlob "test.kt" Nothing "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
-      blobs `shouldBe` [both (emptyBlob "test.kt") b']
+      blobs `shouldBe` [blobPairInserting b']
 
     it "detects language based on filepath for empty language" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-empty-language.json"
-      blobs `shouldBe` [both a b]
+      blobs `shouldBe` [blobPairDiffing a b]
 
     it "throws on blank input" $ do
       h <- openFile "test/fixtures/input/blank.json" ReadMode
@@ -65,6 +64,10 @@ spec = parallel $ do
       h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode
       readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
 
+    it "throws if null on before and after" $ do
+      h <- openFile "test/fixtures/input/diff-null-both-sides.json" ReadMode
+      readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
+
   describe "readBlobsFromHandle" $ do
     it "returns blobs for valid JSON encoded parse input" $ do
       h <- openFile "test/fixtures/input/parse.json" ReadMode

test/Semantic/Spec.hs

@@ -28,13 +28,13 @@ spec = parallel $ do
       output `shouldBe` "(Program\n  (Method\n    (Empty)\n    (Identifier)\n    ([])))\n"
 
   describe "diffTermPair" $ do
-    it "produces an Insert when the first blob is missing" $ do
-      result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) replacing (termIn () []) (termIn () []))
-      result `shouldBe` Diff (Patch (Insert (In () [])))
+    it "produces an Insert when the first term is missing" $ do
+      result <- runTask (diffTermPair replacing (That (termIn () [])))
+      result `shouldBe` (Diff (Patch (Insert (In () []))) :: Diff [] () ())
 
-    it "produces a Delete when the second blob is missing" $ do
-      result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) replacing (termIn () []) (termIn () []))
-      result `shouldBe` Diff (Patch (Delete (In () [])))
+    it "produces a Delete when the second term is missing" $ do
+      result <- runTask (diffTermPair replacing (This (termIn () [])))
+      result `shouldBe` (Diff (Patch (Delete (In () []))) :: Diff [] () ())
 
   where
-    methodsBlob = Blob "def foo\nend\n" "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) (Just Ruby)
+    methodsBlob = Blob "def foo\nend\n" "methods.rb" (Just Ruby)

test/SpecHelpers.hs

@@ -2,44 +2,36 @@
 module SpecHelpers
 ( diffFilePaths
 , parseFilePath
-, readFile
+, readFilePair
 , languageForFilePath
 ) where
 
+import Control.Monad ((<=<))
 import Control.Exception
 import Data.Blob
 import qualified Data.ByteString as B
 import Data.Functor.Both
 import Data.Language
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, fromJust)
 import Data.Source
-import Prelude hiding (readFile)
 import Rendering.Renderer
 import Semantic
 import Semantic.Task
+import qualified Semantic.IO as IO
 import System.FilePath
 
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
 diffFilePaths :: Both FilePath -> IO B.ByteString
-diffFilePaths paths = do
-  blobs <- traverse readFile paths
-  runTask (diffBlobPair SExpressionDiffRenderer blobs)
+diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionDiffRenderer
 
 -- | Returns an s-expression parse tree for the specified FilePath.
 parseFilePath :: FilePath -> IO B.ByteString
-parseFilePath path = do
-  blob <- readFile path
-  runTask (parseBlob SExpressionTermRenderer blob)
+parseFilePath path = IO.readFile path (languageForFilePath path) >>= pure . fromJust >>= runTask . parseBlob SExpressionTermRenderer
 
--- | Read a file to a Blob.
---
--- NB: This is intentionally duplicated from Command.Files because eventually
--- we want to be able to test a core Semantic library that has no knowledge of
--- the filesystem or Git. The tests, however, will still leverage reading files.
-readFile :: FilePath -> IO Blob
-readFile path = do
-  source <- (Just . fromBytes <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe Source))
-  pure $ fromMaybe (emptyBlob path) (sourceBlob path (languageForFilePath path) <$> source)
+-- | Read two files to a BlobPair.
+readFilePair :: Both FilePath -> IO BlobPair
+readFilePair paths = let paths' = fmap (\p -> (p, languageForFilePath p)) paths in
+                     runBothWith IO.readFilePair paths'
 
 -- | Returns a Maybe Language based on the FilePath's extension.
 languageForFilePath :: FilePath -> Maybe Language

test/fixtures/input/diff-null-both-sides.json

@@ -0,0 +1,6 @@
+{
+  "blobs": [{
+    "before": null,
+    "after": null
+  }]
+}

vendor/freer-cofreer

@@ -1 +1 @@
-Subproject commit f18b723579f700674dda90ed1519f6e7298e2117
+Subproject commit 22164cdebd939dc9b4a21b41a5e4968f991435d1