diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 0301bda7e..7d6020158 100644 --- a/src/Data/Blob.hs +++ b/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) diff --git a/src/Data/File.hs b/src/Data/File.hs index a4b4667b8..143004b5a 100644 --- a/src/Data/File.hs +++ b/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 diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index a42b4f2b0..edf619a29 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/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'." diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 3e05784c1..18e39d542 100644 --- a/test/Data/Functor/Listable.hs +++ b/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 diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index d7402db1c..818e20e5a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/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) {\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"