From 060c8f50ff234ba0680496efb21765b3bf8ab00a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 11:19:24 -0500 Subject: [PATCH 1/5] Refactor: use pattern synonyms to construct BlobPairs. The `BlobPair` type is defined as an alias for `Join These Blob`. Though this sacrifices a degree of type safety, it's extremely convenient, as you can get to a Functor and Bifunctor instance very quickly. Pattern-matching on `BlobPair` is less elegant though, as it requires a nested Join then a match on `These`, which is not immediately indicative of what a given pair might do. This adds pattern synonyms for the `Inserting`, `Deleting`, and `Diffing` cases, and removes the less-expressive functions returning such. --- src/Data/Blob.hs | 37 +++++++++++++++++++------------------ test/Semantic/IO/Spec.hs | 14 +++++++------- 2 files changed, 26 insertions(+), 25 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 0301bda7e..b0d42e07e 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,10 @@ module Data.Blob , nullBlob , sourceBlob , noLanguageForBlob -, BlobPair -, These(..) -, blobPairDiffing -, blobPairInserting -, blobPairDeleting +, type BlobPair +, pattern Diffing +, pattern Inserting +, pattern Deleting , decodeBlobPairs , languageForBlobPair , languageTagForBlobPair @@ -80,28 +79,30 @@ instance FromJSON BlobPair where (Nothing, Just a) -> pure $ Join (That 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 #-} 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/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" From c41d60548cf8e2c779db16793708d3dfcc09076a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 11:50:46 -0500 Subject: [PATCH 2/5] Use pattern synonyms in API helpers. --- src/Data/Blob.hs | 8 ++++++++ src/Data/File.hs | 9 +-------- src/Semantic/Api/Helpers.hs | 6 +++--- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index b0d42e07e..b4c11df82 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -10,6 +10,7 @@ module Data.Blob , pattern Diffing , pattern Inserting , pattern Deleting +, maybeBlobPair , decodeBlobPairs , languageForBlobPair , languageTagForBlobPair @@ -90,6 +91,13 @@ 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 (Deleting Blob{..}) = blobLanguage languageForBlobPair (Inserting Blob{..}) = blobLanguage diff --git a/src/Data/File.hs b/src/Data/File.hs index a4b4667b8..42f0e3a2c 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -56,11 +56,4 @@ 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 = maybeBlobPair <$> readBlobFromFile a <*> readBlobFromFile b diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index a42b4f2b0..9f95077af 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Helpers.hs @@ -84,7 +84,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'." From 079ce8baa0a795e041d0e3cdc636c2c8870bb098 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 11:52:21 -0500 Subject: [PATCH 3/5] Eliminate other places where These leaked to implementation. --- src/Data/Blob.hs | 6 +++--- src/Semantic/Api/Helpers.hs | 4 +++- test/Data/Functor/Listable.hs | 2 +- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index b4c11df82..7d6020158 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -75,9 +75,9 @@ 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" pattern Diffing :: Blob -> Blob -> BlobPair diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index 9f95077af..b9cef0ede 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Helpers.hs @@ -78,7 +78,9 @@ apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob] apiBlobsToBlobs = V.toList . fmap apiBlobToBlob apiBlobToBlob :: API.Blob -> Data.Blob -apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language) +apiBlobToBlob API.Blob{..} = case parseRelFile (T.unpack path) of + Just p -> Data.Blob (fromText content) p (apiLanguageToLanguage language) + Nothing -> error "Expected API blob to have a relative path" apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair] apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair 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 From f29f26cc71b93d7a9e9feb64a1844c3d4476cc87 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 12:36:16 -0500 Subject: [PATCH 4/5] Fix some errors that crept in. --- src/Data/File.hs | 6 ++++-- src/Semantic/Api/Helpers.hs | 4 +--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/File.hs b/src/Data/File.hs index 42f0e3a2c..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,4 +55,7 @@ readBlobsFromDir path = do pure (catMaybes blobs) readFilePair :: forall m. (MonadFail m, MonadIO m) => File -> File -> m BlobPair -readFilePair a b = maybeBlobPair <$> readBlobFromFile a <*> readBlobFromFile b +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 b9cef0ede..9f95077af 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Helpers.hs @@ -78,9 +78,7 @@ apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob] apiBlobsToBlobs = V.toList . fmap apiBlobToBlob apiBlobToBlob :: API.Blob -> Data.Blob -apiBlobToBlob API.Blob{..} = case parseRelFile (T.unpack path) of - Just p -> Data.Blob (fromText content) p (apiLanguageToLanguage language) - Nothing -> error "Expected API blob to have a relative path" +apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language) apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair] apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair From 77672564eb308a98c350caa7420a2b0c966e915c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 12:58:51 -0500 Subject: [PATCH 5/5] unused imports --- src/Semantic/Api/Helpers.hs | 2 -- vendor/haskell-tree-sitter | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index 9f95077af..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 diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index de469907a..53dbe815f 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit de469907a0fcd4d522a880c985e533e7849ff8b5 +Subproject commit 53dbe815fd85726484294833dfaece544d5f423d