Merge branch 'alephd-migrate-job' of https://github.com/github/semantic into alephd-migrate-job

src/Data/Blob.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveAnyClass, ExplicitNamespaces, PatternSynonyms #-}
 module Data.Blob
 ( Blob(..)
 , Blobs(..)
@@ -6,11 +6,11 @@ module Data.Blob
 , nullBlob
 , sourceBlob
 , noLanguageForBlob
-, BlobPair
-, These(..)
-, blobPairDiffing
-, blobPairInserting
-, blobPairDeleting
+, type BlobPair
+, pattern Diffing
+, pattern Inserting
+, pattern Deleting
+, maybeBlobPair
 , decodeBlobPairs
 , languageForBlobPair
 , languageTagForBlobPair
@@ -75,33 +75,42 @@ instance FromJSON BlobPair where
     before <- o .:? "before"
     after <- o .:? "after"
     case (before, after) of
-      (Just b, Just a)  -> pure $ Join (These b a)
-      (Just b, Nothing) -> pure $ Join (This b)
-      (Nothing, Just a) -> pure $ Join (That a)
+      (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"
 
-blobPairDiffing :: Blob -> Blob -> BlobPair
-blobPairDiffing a b = Join (These a b)
+pattern Diffing :: Blob -> Blob -> BlobPair
+pattern Diffing a b = Join (These a b)
 
-blobPairInserting :: Blob -> BlobPair
-blobPairInserting = Join . That
+pattern Inserting :: Blob -> BlobPair
+pattern Inserting a = Join (That a)
 
-blobPairDeleting :: Blob -> BlobPair
-blobPairDeleting = Join . This
+pattern Deleting :: Blob -> BlobPair
+pattern Deleting b = Join (This b)
+
+{-# COMPLETE Diffing, Inserting, Deleting #-}
+
+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"
 
 languageForBlobPair :: BlobPair -> Language
-languageForBlobPair (Join (This Blob{..})) = blobLanguage
-languageForBlobPair (Join (That Blob{..})) = blobLanguage
-languageForBlobPair (Join (These a b))
+languageForBlobPair (Deleting Blob{..})  = blobLanguage
+languageForBlobPair (Inserting Blob{..}) = blobLanguage
+languageForBlobPair (Diffing a b)
   | blobLanguage a == Unknown || blobLanguage b == Unknown
     = Unknown
   | otherwise
     = blobLanguage b
 
 pathForBlobPair :: BlobPair -> FilePath
-pathForBlobPair (Join (This Blob{..}))    = blobPath
-pathForBlobPair (Join (That Blob{..}))    = blobPath
-pathForBlobPair (Join (These _ Blob{..})) = blobPath
+pathForBlobPair (Deleting Blob{..})  = blobPath
+pathForBlobPair (Inserting Blob{..}) = blobPath
+pathForBlobPair (Diffing _ Blob{..}) = blobPath
 
 languageTagForBlobPair :: BlobPair -> [(String, String)]
 languageTagForBlobPair pair = showLanguage (languageForBlobPair pair)

src/Data/File.hs

@@ -8,7 +8,6 @@ module Data.File
   , readBlobFromFile'
   , readBlobsFromDir
   , readFilePair
-  , maybeThese
   ) where
 
 import Prologue
@@ -56,11 +55,7 @@ readBlobsFromDir path = do
   pure (catMaybes blobs)
 
 readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair
-readFilePair a b = Join <$> join (maybeThese <$> readBlobFromFile a <*> readBlobFromFile b)
-
-maybeThese :: MonadFail m => Maybe a -> Maybe b -> m (These a b)
-maybeThese a b = case (a, b) of
-  (Just a, Nothing) -> pure (This a)
-  (Nothing, Just b) -> pure (That b)
-  (Just a, Just b)  -> pure (These a b)
-  _                 -> Prologue.fail "expected file pair with content on at least one side"
+readFilePair a b = do
+  before <- readBlobFromFile a
+  after  <- readBlobFromFile b
+  maybeBlobPair before after

src/Semantic/Api/Helpers.hs

@@ -12,14 +12,12 @@ module Semantic.Api.Helpers
   , apiBlobPairToBlobPair
   ) where
 
-import           Data.Bifunctor.Join
 import qualified Data.Blob as Data
 import qualified Data.Language as Data
 import           Data.Source (fromText)
 import qualified Data.Span as Data
 import qualified Data.Text as T
 import qualified Data.Vector as V
-import           Data.These
 import qualified Semantic.Api.LegacyTypes as Legacy
 import qualified Semantic.Api.V1.CodeAnalysisPB as API
 
@@ -84,7 +82,7 @@ apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair]
 apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair
 
 apiBlobPairToBlobPair :: API.BlobPair -> Data.BlobPair
-apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Join (These (apiBlobToBlob before) (apiBlobToBlob after))
-apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Join (This (apiBlobToBlob before))
-apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Join (That (apiBlobToBlob after))
+apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Data.Diffing (apiBlobToBlob before) (apiBlobToBlob after)
+apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Data.Deleting (apiBlobToBlob before)
+apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Data.Inserting (apiBlobToBlob after)
 apiBlobPairToBlobPair _ = Prelude.error "Expected BlobPair to have either 'before' and/or 'after'."

test/Data/Functor/Listable.hs

@@ -570,7 +570,7 @@ instance Listable Span where
 instance Listable Blob where
   tiers = cons3 Blob
 
-instance Listable (Join These Blob) where
+instance Listable BlobPair where
   tiers = liftTiers tiers
 
 instance Listable Source where

test/Semantic/IO/Spec.hs

@@ -38,34 +38,34 @@ spec = parallel $ do
       putStrLn "step 1"
       blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
       putStrLn "done"
-      blobs `shouldBe` [blobPairDiffing a b]
+      blobs `shouldBe` [Diffing a b]
 
     it "returns blobs when there's no before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json"
-      blobs `shouldBe` [blobPairInserting b]
+      blobs `shouldBe` [Inserting b]
 
     it "returns blobs when there's null before" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json"
-      blobs `shouldBe` [blobPairInserting b]
+      blobs `shouldBe` [Inserting b]
 
     it "returns blobs when there's no after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json"
-      blobs `shouldBe` [blobPairDeleting a]
+      blobs `shouldBe` [Deleting a]
 
     it "returns blobs when there's null after" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json"
-      blobs `shouldBe` [blobPairDeleting a]
+      blobs `shouldBe` [Deleting 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` [blobPairInserting b']
+      blobs `shouldBe` [Inserting b']
 
     it "detects language based on filepath for empty language" $ do
       blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json"
-      blobs `shouldBe` [blobPairDiffing a b]
+      blobs `shouldBe` [Diffing a b]
 
     it "throws on blank input" $ do
       h <- openFileForReading "test/fixtures/cli/blank.json"