Use Join These Blob instead

src/Data/Blob.hs

@@ -10,12 +10,16 @@ module Data.Blob
 , sourceBlob
 , nullOid
 , BlobPair
+, blobPairDiffing
+, blobPairInserting
+, blobPairDeleting
 , languageForBlobPair
 , languageTagForBlobPair
 , pathForBlobPair
 ) where
 
 import Data.ByteString.Char8 (ByteString, pack)
+import Data.Bifunctor.Join
 import Data.Language
 import Data.These
 import Data.Maybe (isJust)
@@ -24,17 +28,29 @@ import Data.Word
 import Numeric
 
 
-type BlobPair = These Blob Blob
+-- | 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 (This Blob{..}) = blobLanguage
-languageForBlobPair (That Blob{..}) = blobLanguage
-languageForBlobPair (These _ Blob{..}) = blobLanguage
+languageForBlobPair (Join (This Blob{..})) = blobLanguage
+languageForBlobPair (Join (That Blob{..})) = blobLanguage
+languageForBlobPair (Join (These _ Blob{..})) = blobLanguage
 
 pathForBlobPair :: BlobPair -> FilePath
-pathForBlobPair (This Blob{..}) = blobPath
-pathForBlobPair (That Blob{..}) = blobPath
-pathForBlobPair (These _ Blob{..}) = blobPath
+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)

src/Rendering/JSON.hs

@@ -7,22 +7,19 @@ import Data.Aeson (ToJSON, toJSON, object, (.=))
 import Data.Aeson as A
 import Data.Blob
 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 => BlobPair -> a -> Map.Map Text Value
 renderJSONDiff blobs diff = Map.fromList
   [ ("diff", toJSON diff)
-  , ("oids", toJSON (decodeUtf8 . blobOid <$> biList blobs))
-  , ("paths", toJSON (blobPath <$> biList blobs))
+  , ("oids", toJSON (decodeUtf8 . blobOid <$> (biList . runJoin) blobs))
+  , ("paths", toJSON (blobPath <$> (biList . runJoin) blobs))
   ]
 
 data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a }
@@ -31,5 +28,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,6 +21,7 @@ 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
@@ -163,7 +164,7 @@ renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Fol
 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 bimap blobPath blobPath blobs of
+        summaryKey = T.pack $ case bimap blobPath blobPath (runJoin blobs) of
            This before -> before
            That after -> after
            These before after | before == after -> after

src/Semantic.hs

@@ -15,6 +15,7 @@ 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
@@ -103,9 +104,9 @@ 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) -> (These Blob 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 <- bidistributeFor blobs parse parse
+          terms <- bidistributeFor (runJoin blobs) parse parse
           time "diff" languageTag $ do
             diff <- diffTermPair diff terms
             writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)

src/Semantic/IO.hs

@@ -46,9 +46,9 @@ readFilePair a b = do
   before <- uncurry readFile a
   after <- uncurry readFile b
   case (Blob.blobExists before, Blob.blobExists after) of
-    (True, False) -> pure (This before)
-    (False, True) -> pure (That after)
-    _ -> pure (These before after)
+    (True, False) -> pure (Join (This before))
+    (False, True) -> pure (Join (That after))
+    _ -> pure (Join (These before after))
 
 isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path) >>= pure
@@ -63,7 +63,7 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
   where
     toBlobPairs :: BlobDiff -> [Blob.BlobPair]
     toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
-    toBlobPair blobs = runJoin (toBlob <$> blobs)
+    toBlobPair blobs = toBlob <$> blobs
 
 -- | Read JSON encoded blobs from a handle.
 readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]

src/Semantic/Util.hs

@@ -8,6 +8,7 @@ import Data.Align.Generic
 import Data.Blob
 import Data.Diff
 import Data.Functor.Classes
+import Data.Bifunctor.Join
 import Data.Range
 import Data.Record
 import Data.Span
@@ -34,4 +35,4 @@ diffWithParser :: (HasField fields Data.Span.Span,
                   -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
 diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
   where
-    run parse blobs = bidistributeFor blobs parse parse >>= diffTermPair diffTerms
+    run parse blobs = bidistributeFor (runJoin blobs) parse parse >>= diffTermPair diffTerms

test/Semantic/IO/Spec.hs

@@ -28,34 +28,34 @@ spec = parallel $ do
     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` [These 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` [That 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` [That 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` [This a]
+      blobs `shouldBe` [blobPairDeleting a]
 
     it "returns blobs when there's null after" $ do
       blobs <- blobsFromFilePath "test/fixtures/input/diff-null-after.json"
-      blobs `shouldBe` [This a]
+      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` [That 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` [These a b]
+      blobs `shouldBe` [blobPairDiffing a b]
 
     it "throws on blank input" $ do
       h <- openFile "test/fixtures/input/blank.json" ReadMode