From 2604e940522a087b6c1f7de6ce68d5695bf3292d Mon Sep 17 00:00:00 2001
From: Rob Rix <robrix@github.com>
Date: Thu, 17 Oct 2019 05:16:23 -0400
Subject: [PATCH] Define BlobPair as a newtype.

---
 src/Control/Effect/Parse.hs |  4 ++--
 src/Data/Blob.hs            | 13 +++++++------
 src/Rendering/JSON.hs       |  4 ++--
 src/Semantic/Api/Diffs.hs   |  2 +-
 4 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs
index 07be28411..8fd43890b 100644
--- a/src/Control/Effect/Parse.hs
+++ b/src/Control/Effect/Parse.hs
@@ -10,7 +10,7 @@ module Control.Effect.Parse
 import Control.Effect.Carrier
 import Control.Effect.Error
 import Control.Exception (SomeException)
-import Data.Bifunctor.Join
+import Data.Bitraversable
 import Data.Blob
 import Data.Language
 import qualified Data.Map as Map
@@ -56,5 +56,5 @@ parsePairWith
   -> BlobPair                                                     -- ^ The blob pair to parse.
   -> m a
 parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of
-  Just (SomeParser parser) -> traverse (parse parser) blobPair >>= with . runJoin
+  Just (SomeParser parser) -> bitraverse (parse parser) (parse parser) (getBlobPair blobPair) >>= with
   _                        -> noLanguageForBlob (pathForBlobPair blobPair)
diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs
index e4f76905d..d63caf0a6 100644
--- a/src/Data/Blob.hs
+++ b/src/Data/Blob.hs
@@ -13,7 +13,7 @@ module Data.Blob
 , nullBlob
 , sourceBlob
 , noLanguageForBlob
-, type BlobPair
+, BlobPair(..)
 , pattern Diffing
 , pattern Inserting
 , pattern Deleting
@@ -101,7 +101,8 @@ 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.
-type BlobPair = Join These Blob
+newtype BlobPair = BlobPair { getBlobPair :: These Blob Blob }
+  deriving (Eq, Show)
 
 instance FromJSON BlobPair where
   parseJSON = withObject "BlobPair" $ \o -> do
@@ -114,13 +115,13 @@ instance FromJSON BlobPair where
       _                 -> Prelude.fail "Expected object with 'before' and/or 'after' keys only"
 
 pattern Diffing :: Blob -> Blob -> BlobPair
-pattern Diffing a b = Join (These a b)
+pattern Diffing a b = BlobPair (These a b)
 
 pattern Inserting :: Blob -> BlobPair
-pattern Inserting a = Join (That a)
+pattern Inserting a = BlobPair (That a)
 
 pattern Deleting :: Blob -> BlobPair
-pattern Deleting b = Join (This b)
+pattern Deleting b = BlobPair (This b)
 
 {-# COMPLETE Diffing, Inserting, Deleting #-}
 
@@ -151,7 +152,7 @@ languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)
   where showLanguage = pure . (,) "language" . show
 
 pathKeyForBlobPair :: BlobPair -> FilePath
-pathKeyForBlobPair blobs = case bimap blobPath blobPath (runJoin blobs) of
+pathKeyForBlobPair blobs = case bimap blobPath blobPath (getBlobPair blobs) of
    This before -> before
    That after -> after
    These before after | before == after -> after
diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs
index 3bf8669be..39dd4f0e7 100644
--- a/src/Rendering/JSON.hs
+++ b/src/Rendering/JSON.hs
@@ -56,8 +56,8 @@ newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair }
   deriving (Eq, Show)
 
 instance ToJSON JSONStat where
-  toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs)))
-  toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs))))
+  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))))
 
 -- | Render a term to a value representing its JSON.
 renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs
index b29388a57..98d2a2be1 100644
--- a/src/Semantic/Api/Diffs.hs
+++ b/src/Semantic/Api/Diffs.hs
@@ -184,7 +184,7 @@ decoratingDiffWith
   -> BlobPair                                                   -- ^ The blob pair to parse.
   -> m output
 decoratingDiffWith parsers decorate render blobPair = parsePairWith parsers (render <=< diffTerms blobPair . bimap (decorate blobL) (decorate blobR)) blobPair where
-  (blobL, blobR) = fromThese errorBlob errorBlob (runJoin blobPair)
+  (blobL, blobR) = fromThese errorBlob errorBlob (getBlobPair blobPair)
   errorBlob = Prelude.error "evaluating blob on absent side"
 
 diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m)