diff --git a/.hlint.yaml b/.hlint.yaml index e8e2be0e8..4111be9a7 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -34,6 +34,10 @@ # Change the severity of hints we don’t want to fail CI for - suggest: {name: Eta reduce} +# While I think DerivingStrategies is good, it's too noisy to suggest by default +- ignore: + name: Use DerivingStrategies + # Ignore eta reduce in the assignment modules - ignore: name: Eta reduce @@ -45,8 +49,29 @@ - ignore: {name: Use ., within: [Analysis.Abstract.Graph.graphingModules, Semantic.Distribute]} -- ignore: {name: Reduce duplication, within: [Semantic.Util, Semantic.UtilDisabled]} -- ignore: {name: Use newtype instead of data, within: [Semantic.Api.V1.CodeAnalysisPB]} +- ignore: + within: + - Proto.Semantic + - Proto.Semantic_Fields + - Proto.Semantic_JSON + +- ignore: + name: Reduce duplication + within: + - Semantic.Util + +# hlint has issues with QuantifiedConstraints (see https://github.com/ndmitchell/hlint/issues/759) +# Once the above is fixed, we can drop this error. + +- ignore: { name: Parse error } + +# hlint is too paranoid about NonEmpty functions (https://github.com/ndmitchell/hlint/issues/787) + +- ignore: + name: Avoid restricted function + within: + - Language.Python.Syntax + - Data.Syntax.Expression # Our customized warnings diff --git a/.travis.yml b/.travis.yml index 190f87e38..12ea1e630 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,9 +24,14 @@ matrix: before_install: - mkdir -p $HOME/.local/bin +- curl -L -o /tmp/hlint.tar.gz "https://github.com/ndmitchell/hlint/releases/download/v2.2.3/hlint-2.2.3-x86_64-linux.tar.gz" +- tar -xf /tmp/hlint.tar.gz -C /tmp +- cp /tmp/hlint-2.2.3/hlint $HOME/.local/bin +- cp -r /tmp/hlint-2.2.3/data $HOME/.local/bin - "PATH=/opt/ghc/bin:$HOME/local/bin:$PATH" - ghc --version - cabal --version +- hlint --version install: - cabal v2-update -v @@ -34,6 +39,7 @@ install: - cabal v2-build --only-dependencies script: +- hlint src semantic-python - cabal v2-build - cabal v2-run semantic:test - cabal v2-run semantic-core:test diff --git a/semantic-core/src/Core/Core.hs b/semantic-core/src/Core/Core.hs index 481a11b7b..84b475da3 100644 --- a/semantic-core/src/Core/Core.hs +++ b/semantic-core/src/Core/Core.hs @@ -26,6 +26,7 @@ module Core.Core , load , record , (...) +, (.?) , (.=) , Ann(..) , ann @@ -75,6 +76,8 @@ data Core f a | Record [(Name, f a)] -- | Projection from a record. | f a :. Name + -- | Projection of a record, with failure. + | f a :? Name -- | Assignment of a value to the reference returned by the lhs. | f a := f a deriving (Foldable, Functor, Generic1, Traversable) @@ -105,6 +108,7 @@ instance RightModule Core where Load b >>=* f = Load (b >>= f) Record fs >>=* f = Record (map (fmap (>>= f)) fs) (a :. b) >>=* f = (a >>= f) :. b + (a :? b) >>=* f = (a >>= f) :. b (a := b) >>=* f = (a >>= f) := (b >>= f) @@ -209,6 +213,11 @@ a ... b = send (a :. b) infixl 9 ... +(.?) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a +a .? b = send (a :? b) + +infixl 9 .? + (.=) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a a .= b = send (a := b) diff --git a/semantic-core/src/Core/Eval.hs b/semantic-core/src/Core/Eval.hs index 01ac38d0f..f7c23b5d7 100644 --- a/semantic-core/src/Core/Eval.hs +++ b/semantic-core/src/Core/Eval.hs @@ -20,7 +20,7 @@ import Control.Monad ((>=>)) import Core.Core as Core import Core.Name import Data.Functor -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import GHC.Stack import Prelude hiding (fail) import Source.Span @@ -68,6 +68,11 @@ eval Analysis{..} eval = \case a :. b -> do a' <- ref a a' ... b >>= maybe (freeVariable (show b)) (deref' b) + a :? b -> do + a' <- ref a + mFound <- a' ... b + bool (isJust mFound) + a := b -> do b' <- eval b addr <- ref a diff --git a/semantic-core/src/Core/Parser.hs b/semantic-core/src/Core/Parser.hs index 34e417364..1743bae0d 100644 --- a/semantic-core/src/Core/Parser.hs +++ b/semantic-core/src/Core/Parser.hs @@ -11,12 +11,12 @@ module Core.Parser -- Consult @doc/grammar.md@ for an EBNF grammar. import Control.Applicative +import Control.Category ((>>>)) import Control.Effect.Carrier import Core.Core ((:<-) (..), Core) import qualified Core.Core as Core import Core.Name import qualified Data.Char as Char -import Data.Foldable (foldl') import Data.String import qualified Text.Parser.Token as Token import qualified Text.Parser.Token.Highlight as Highlight @@ -61,7 +61,12 @@ application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t application = projection `chainl1` (pure (Core.$$)) projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) -projection = foldl' (Core....) <$> atom <*> many (namedValue <$ dot <*> name) +projection = let a <$$> b = flip a <$> b in do + head <- atom + res <- many (choice [ (Core..?) <$$> (symbol ".?" *> identifier) + , (Core....) <$$> (dot *> identifier) + ]) + pure (foldr (>>>) id res head) atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) atom = choice diff --git a/semantic-core/src/Core/Pretty.hs b/semantic-core/src/Core/Pretty.hs index 808f02f69..5babed821 100644 --- a/semantic-core/src/Core/Pretty.hs +++ b/semantic-core/src/Core/Pretty.hs @@ -74,6 +74,7 @@ prettyCore style = unPrec . go . fmap name Load p -> prec 3 (keyword "load" <+> withPrec 9 (go p)) item :. body -> prec 9 (withPrec 9 (go item) <> symbol "." <> name body) + item :? body -> prec 9 (withPrec 9 (go item) <> symbol ".?" <> name body) lhs := rhs -> prec 3 . group . nest 2 $ vsep [ withPrec 4 (go lhs) diff --git a/semantic-core/test/Generators.hs b/semantic-core/test/Generators.hs index 01cfd6feb..d96a82cdf 100644 --- a/semantic-core/test/Generators.hs +++ b/semantic-core/test/Generators.hs @@ -70,5 +70,6 @@ expr = Gen.recursive Gen.choice atoms , Gen.subterm expr Core.load , record expr , Gen.subtermM expr (\ x -> (x Core....) . namedValue <$> name) + , Gen.subtermM expr (\ x -> (x Core..?) . namedValue <$> name) , Gen.subterm2 expr expr (Core..=) ] diff --git a/semantic-python/src/Prelude.score b/semantic-python/src/Prelude.score index f9a495c13..4cb5973f9 100644 --- a/semantic-python/src/Prelude.score +++ b/semantic-python/src/Prelude.score @@ -1,14 +1,20 @@ { - type <- \name -> \bases -> \dict -> - #record { __name: name, __bases: bases, __dict: dict }; + type <- \name -> \super -> \slots -> + #record { __name: name, __super: super, __slots: slots }; instance <- \class -> \prim -> \slots -> #record { __class: class, __prim: prim, __slots: slots }; - object <- type "object" #unit #record{}; + object <- type "object" type #record{}; str <- type "str" object #record { }; - str.__class.__new__ = (\contents -> instance str contents #record{}); + str.__new__ = (\contents -> instance str contents #record{}); #record { type: type, object: object, str: str } + + getitem <- rec getitem = \item -> \attr -> + if item.slots.?attr then item.slots.attr else #unit; + + #record { type: type, object: object, getitem: getitem } + } diff --git a/semantic-python/test/Directive.hs b/semantic-python/test/Directive.hs index db95ff4dc..cd81413e4 100644 --- a/semantic-python/test/Directive.hs +++ b/semantic-python/test/Directive.hs @@ -7,8 +7,8 @@ module Directive ( Directive (..) import Control.Applicative import Control.Monad import Core.Core (Core) -import qualified Core.Parser as Core.Parser -import qualified Core.Pretty as Core.Pretty +import qualified Core.Parser +import qualified Core.Pretty import Core.Name (Name) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString diff --git a/semantic-python/test/Instances.hs b/semantic-python/test/Instances.hs index 8e038b6e2..857f0f7b8 100644 --- a/semantic-python/test/Instances.hs +++ b/semantic-python/test/Instances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, LambdaCase, StandaloneDeriving, FlexibleInstances, NamedFieldPuns, OverloadedStrings, QuantifiedConstraints, TypeOperators, UndecidableInstances, TypeApplications #-} +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, NamedFieldPuns, OverloadedStrings, QuantifiedConstraints, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Instances () where diff --git a/semantic.cabal b/semantic.cabal index 3c0602d7e..4f1687892 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -67,9 +67,7 @@ common dependencies , semantic-source ^>= 0.0 , semilattices ^>= 0.0.0.3 , streaming ^>= 0.2.2.0 - , streaming-bytestring ^>= 0.1.6 , text ^>= 1.2.3.1 - , these >= 0.7 && <1 , unix ^>= 2.7.2.2 , lingo ^>= 0.3.0.0 @@ -148,9 +146,9 @@ library , Data.Blob.IO , Data.Diff , Data.Duration + , Data.Edit , Data.Error , Data.Flag - , Data.Functor.Both , Data.Functor.Classes.Generic , Data.Graph , Data.Graph.ControlFlowVertex @@ -160,7 +158,6 @@ library , Data.JSON.Fields , Data.Language , Data.Map.Monoidal - , Data.Patch , Data.Project , Data.Quieterm , Data.Semigroup.App @@ -229,7 +226,6 @@ library , Semantic.Config , Semantic.Distribute , Semantic.Env - , Semantic.Git , Semantic.Graph , Semantic.IO , Semantic.Resolution @@ -288,8 +284,6 @@ library , semantic-tags ^>= 0 , semigroupoids ^>= 5.3.2 , split ^>= 0.2.3.3 - , streaming-attoparsec ^>= 1.0.0.1 - , streaming-process ^>= 0.1 , stm-chans ^>= 3.0.0.4 , template-haskell ^>= 2.14 , time ^>= 1.8.0.2 @@ -362,7 +356,6 @@ test-suite test , hspec >= 2.6 && <3 , hspec-core >= 2.6 && <3 , hspec-expectations ^>= 0.8.2 - , shelly >= 1.5 && <2 , tasty ^>= 1.2.3 , tasty-golden ^>= 2.3.2 , tasty-hedgehog ^>= 1.0.0.1 @@ -384,7 +377,7 @@ test-suite parse-examples , foldl ^>= 1.4.5 , resourcet ^>= 1.2 , streaming - , streaming-bytestring + , streaming-bytestring ^>= 0.1.6 , tasty , tasty-hunit diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a5bc48e1f..ca7165132 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -292,15 +292,9 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) -> m value liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure) -data NumericFunction = NumericFunction (forall a . Num a => a -> a) +newtype NumericFunction = NumericFunction { runNumericFunction :: forall a . Num a => a -> a } -runNumericFunction :: Num a => NumericFunction -> a -> a -runNumericFunction (NumericFunction f) a = f a - -data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber) - -runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber -runNumeric2Function (Numeric2Function f) a b = f a b +newtype Numeric2Function = Numeric2Function { runNumeric2Function :: forall a b. Number a -> Number b -> SomeNumber } data Numeric value (m :: * -> *) k = Integer Integer (value -> m k) @@ -347,15 +341,9 @@ unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) -> m value unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure) -data BitwiseFunction = BitwiseFunction (forall a . Bits a => a -> a) +newtype BitwiseFunction = BitwiseFunction { runBitwiseFunction :: forall a . Bits a => a -> a } -runBitwiseFunction :: Bits a => BitwiseFunction -> a -> a -runBitwiseFunction (BitwiseFunction f) a = f a - -data Bitwise2Function = Bitwise2Function (forall a . (Integral a, Bits a) => a -> a -> a) - -runBitwise2Function :: (Integral a, Bits a) => Bitwise2Function -> a -> a -> a -runBitwise2Function (Bitwise2Function f) a b = f a b +newtype Bitwise2Function = Bitwise2Function { runBitwise2Function :: forall a . (Integral a, Bits a) => a -> a -> a } data Bitwise value (m :: * -> *) k = CastToInteger value (value -> m k) diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index 4dc1d6243..12dc5dcbe 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -63,7 +63,7 @@ runParser timeout blob@Blob{..} parser = case parser of let term = cmarkParser blobSource in length term `seq` pure term -data ParseFailure = ParseFailure String +newtype ParseFailure = ParseFailure String deriving (Show, Typeable) instance Exception ParseFailure diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index 747151e12..c391143ec 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -12,9 +12,9 @@ import Control.Effect.Error import Control.Exception (SomeException) import Data.Bitraversable import Data.Blob +import Data.Edit import Data.Language import qualified Data.Map as Map -import Data.These import Parsing.Parser data Parse m k @@ -51,11 +51,11 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of -- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair. parsePairWith :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) - => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. - -> (forall term . c term => These (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. - -> BlobPair -- ^ The blob pair to parse. + => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. + -> (forall term . c term => Edit (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. + -> BlobPair -- ^ The blob pair to parse. -> m a parsePairWith parsers with blobPair = case Map.lookup (languageForBlobPair blobPair) parsers of - Just (SomeParser parser) -> bitraverse (p parser) (p parser) (getBlobPair blobPair) >>= with + Just (SomeParser parser) -> bitraverse (p parser) (p parser) blobPair >>= with _ -> noLanguageForBlob (pathForBlobPair blobPair) where p parser blob = (,) blob <$> parse parser blob diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index d63caf0a6..80ae3c825 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -13,10 +13,7 @@ module Data.Blob , nullBlob , sourceBlob , noLanguageForBlob -, BlobPair(..) -, pattern Diffing -, pattern Inserting -, pattern Deleting +, BlobPair , maybeBlobPair , decodeBlobPairs , languageForBlobPair @@ -30,6 +27,7 @@ import Prologue import Control.Effect.Error import Data.Aeson import qualified Data.ByteString.Lazy as BL +import Data.Edit import Data.JSON.Fields import Data.Language import Source.Source (Source) @@ -101,62 +99,33 @@ 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. -newtype BlobPair = BlobPair { getBlobPair :: These Blob Blob } - deriving (Eq, Show) +type BlobPair = Edit Blob Blob instance FromJSON BlobPair where - parseJSON = withObject "BlobPair" $ \o -> do - before <- o .:? "before" - after <- o .:? "after" - case (before, after) of - (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 -pattern Diffing a b = BlobPair (These a b) - -pattern Inserting :: Blob -> BlobPair -pattern Inserting a = BlobPair (That a) - -pattern Deleting :: Blob -> BlobPair -pattern Deleting b = BlobPair (This b) - -{-# COMPLETE Diffing, Inserting, Deleting #-} + parseJSON = withObject "BlobPair" $ \o -> + fromMaybes <$> (o .:? "before") <*> (o .:? "after") + >>= maybeM (Prelude.fail "Expected object with 'before' and/or 'after' keys only") 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" +maybeBlobPair a b = maybeM (Prologue.fail "expected file pair with content on at least one side") (fromMaybes a b) languageForBlobPair :: BlobPair -> Language -languageForBlobPair (Deleting b) = blobLanguage b -languageForBlobPair (Inserting b) = blobLanguage b -languageForBlobPair (Diffing a b) - | blobLanguage a == Unknown || blobLanguage b == Unknown - = Unknown - | otherwise - = blobLanguage b +languageForBlobPair = mergeEdit combine . bimap blobLanguage blobLanguage where + combine a b + | a == Unknown || b == Unknown = Unknown + | otherwise = b pathForBlobPair :: BlobPair -> FilePath -pathForBlobPair x = blobPath $ case x of - (Inserting b) -> b - (Deleting b) -> b - (Diffing _ b) -> b +pathForBlobPair = blobPath . mergeEdit (const id) languageTagForBlobPair :: BlobPair -> [(String, String)] languageTagForBlobPair pair = showLanguage (languageForBlobPair pair) where showLanguage = pure . (,) "language" . show pathKeyForBlobPair :: BlobPair -> FilePath -pathKeyForBlobPair blobs = case bimap blobPath blobPath (getBlobPair blobs) of - This before -> before - That after -> after - These before after | before == after -> after - | otherwise -> before <> " -> " <> after +pathKeyForBlobPair = mergeEdit combine . bimap blobPath blobPath where + combine before after | before == after = after + | otherwise = before <> " -> " <> after instance ToJSONFields Blob where toJSONFields p = [ "path" .= blobPath p, "language" .= blobLanguage p] diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 9ab95ac64..ae19501ff 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -6,8 +6,6 @@ module Data.Blob.IO ( readBlobFromFile , readBlobFromFile' , readBlobsFromDir - , readBlobsFromGitRepo - , readBlobsFromGitRepoPath , readFilePair ) where @@ -17,12 +15,9 @@ import qualified Control.Concurrent.Async as Async import Data.Blob import qualified Data.ByteString as B import Data.Language -import Data.Text.Encoding (decodeUtf8) -import qualified Semantic.Git as Git import Semantic.IO import qualified Source.Source as Source import qualified System.Path as Path -import qualified System.Path.PartClass as Part -- | Read a utf8-encoded file to a 'Blob'. readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob) @@ -42,28 +37,6 @@ readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] readBlobsFromDir path = liftIO . fmap catMaybes $ findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForTypedPath) -readBlobsFromGitRepoPath :: (Part.AbsRel ar, MonadIO m) => Path.Dir ar -> Git.OID -> [Path.RelFile] -> [Path.RelFile] -> m [Blob] -readBlobsFromGitRepoPath path oid excludePaths includePaths - = readBlobsFromGitRepo (Path.toString path) oid (fmap Path.toString excludePaths) (fmap Path.toString includePaths) - --- | Read all blobs from a git repo. Prefer readBlobsFromGitRepoPath, which is typed. -readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> [FilePath] -> m [Blob] -readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybes $ - Git.lsTree path oid >>= Async.mapConcurrently (blobFromTreeEntry path) - where - -- Only read tree entries that are normal mode, non-minified blobs in a language we can parse. - blobFromTreeEntry :: FilePath -> Git.TreeEntry -> IO (Maybe Blob) - blobFromTreeEntry gitDir (Git.TreeEntry Git.NormalMode Git.BlobObject oid path) - | lang <- languageForFilePath path - , lang `elem` codeNavLanguages - , not (pathIsMinified path) - , path `notElem` excludePaths - , null includePaths || path `elem` includePaths - = Just . sourceBlob' path lang oid <$> Git.catFile gitDir oid - blobFromTreeEntry _ _ = pure Nothing - - sourceBlob' filepath language (Git.OID oid) source = makeBlob source filepath language (decodeUtf8 oid) - readFilePair :: MonadIO m => File -> File -> m BlobPair readFilePair a b = do before <- readBlobFromFile a diff --git a/src/Data/Diff.hs b/src/Data/Diff.hs index 94c0d3999..2e89e98fb 100644 --- a/src/Data/Diff.hs +++ b/src/Data/Diff.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE DataKinds, LambdaCase, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-} module Data.Diff ( Diff(..) , DiffF(..) -, replacing -, replaceF +, comparing +, compareF , inserting , insertF , deleting @@ -18,10 +18,10 @@ import Data.Aeson import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable +import Data.Edit import Data.Functor.Classes import Data.Functor.Foldable import Data.JSON.Fields -import Data.Patch import Data.Term import Text.Show @@ -30,19 +30,19 @@ newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff sy -- | A single entry within a recursive 'Diff'. data DiffF syntax ann1 ann2 recur - -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation. - = Patch (Patch (TermF syntax ann1 recur) - (TermF syntax ann2 recur)) + -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Compare'd 'TermF's, consisting of syntax labelled with an annotation. + = Patch (Edit (TermF syntax ann1 recur) + (TermF syntax ann2 recur)) -- | An unchanged node, consisting of syntax labelled with both the original annotations. - | Merge (TermF syntax (ann1, ann2) recur) + | Merge (TermF syntax (ann1, ann2) recur) --- | Constructs a 'Diff' replacing one 'Term' with another recursively. -replacing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2 -replacing (Term (In a1 r1)) (Term (In a2 r2)) = replaceF (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2)) +-- | Constructs a 'Diff' comparing one 'Term' with another recursively. +comparing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2 +comparing (Term (In a1 r1)) (Term (In a2 r2)) = compareF (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2)) --- | Constructs a 'Diff' replacing one 'TermF' populated by further 'Diff's with another. -replaceF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2 -replaceF t1 t2 = Diff (Patch (Replace t1 t2)) +-- | Constructs a 'Diff' comparing one 'TermF' populated by further 'Diff's with another. +compareF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2 +compareF t1 t2 = Diff (Patch (Compare t1 t2)) -- | Constructs a 'Diff' inserting a 'Term' recursively. inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2 @@ -75,8 +75,8 @@ merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax)) -diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))] -diffPatches = para $ \ diff -> case diff of +diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Edit (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))] +diffPatches = para $ \case Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch Merge merge -> foldMap snd merge diff --git a/src/Data/Edit.hs b/src/Data/Edit.hs new file mode 100644 index 000000000..a98fde90b --- /dev/null +++ b/src/Data/Edit.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE LambdaCase #-} +module Data.Edit +( Edit(..) +, edit +, mergeEdit +, fromMaybes +) where + +import Control.Applicative ((<|>), liftA2) +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable +import Data.Functor.Classes +import GHC.Generics (Generic, Generic1) + +-- | The deletion, insertion, or comparison of values. +data Edit a b + = Delete a + | Insert b + | Compare a b + deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) + + +-- | Eliminate an 'Edit' by case analysis. +edit :: (l -> a) -> (r -> a) -> (l -> r -> a) -> Edit l r -> a +edit delete insert compare = \case + Delete a -> delete a + Insert b -> insert b + Compare a b -> compare a b + +-- | Extract the values from an 'Edit', combining 'Compare's with the passed function. +mergeEdit :: (a -> a -> a) -> Edit a a -> a +mergeEdit = edit id id + +fromMaybes :: Maybe a -> Maybe b -> Maybe (Edit a b) +fromMaybes a b = liftA2 Compare a b <|> Delete <$> a <|> Insert <$> b + + +instance Bifunctor Edit where + bimap = bimapDefault + +instance Bifoldable Edit where + bifoldMap = bifoldMapDefault + +instance Bitraversable Edit where + bitraverse f g = \case + Delete a -> Delete <$> f a + Insert b -> Insert <$> g b + Compare a b -> Compare <$> f a <*> g b + +instance Eq2 Edit where + liftEq2 eql eqr = curry $ \case + (Delete a1 , Delete a2 ) -> eql a1 a2 + (Insert b1, Insert b2) -> eqr b1 b2 + (Compare a1 b1, Compare a2 b2) -> eql a1 a2 && eqr b1 b2 + _ -> False + +instance Ord2 Edit where + liftCompare2 cmpl cmpr = curry $ \case + (Delete a1 , Delete a2 ) -> cmpl a1 a2 + (Delete _ , _ ) -> LT + (Insert b1, Insert b2) -> cmpr b1 b2 + (Insert _ , _ ) -> LT + (Compare a1 b1, Compare a2 b2) -> cmpl a1 a2 <> cmpr b1 b2 + _ -> GT + +instance Show2 Edit where + liftShowsPrec2 spl _ spr _ d = \case + Delete a -> showsUnaryWith spl "Delete" d a + Insert b -> showsUnaryWith spr "Insert" d b + Compare a b -> showsBinaryWith spl spr "Compare" d a b diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs deleted file mode 100644 index 09658aea3..000000000 --- a/src/Data/Functor/Both.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DerivingVia #-} - -module Data.Functor.Both -( Both (..) -, runBothWith -) where - -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Monoid.Generic -import GHC.Generics - --- | A computation over both sides of a pair. -data Both a = Both a a - deriving (Eq, Show, Ord, Functor, Foldable, Traversable, Generic1, Generic) - deriving Semigroup via GenericSemigroup (Both a) - deriving Monoid via GenericMonoid (Both a) - deriving (Eq1, Show1, Ord1) via Generically Both - --- | Apply a function to `Both` sides of a computation. --- The eliminator/catamorphism over 'Both'. -runBothWith :: (a -> a -> b) -> Both a -> b -runBothWith f (Both a b) = f a b diff --git a/src/Data/ImportPath.hs b/src/Data/ImportPath.hs index 22f9201a2..a85cd16ba 100644 --- a/src/Data/ImportPath.hs +++ b/src/Data/ImportPath.hs @@ -19,8 +19,9 @@ data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative importPath :: Text -> ImportPath importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathType path) where - pathType xs | not (T.null xs), T.head xs == '.' = Relative -- head call here is safe - | otherwise = NonRelative + pathType xs | startsWithDot xs = Relative -- head call here is safe + | otherwise = NonRelative + startsWithDot t = fmap fst (T.uncons t) == Just '.' defaultAlias :: ImportPath -> Name defaultAlias = name . T.pack . takeFileName . unPath diff --git a/src/Data/JSON/Fields.hs b/src/Data/JSON/Fields.hs index c199425c7..2556f62e7 100644 --- a/src/Data/JSON/Fields.hs +++ b/src/Data/JSON/Fields.hs @@ -9,6 +9,7 @@ module Data.JSON.Fields ) where import Data.Aeson +import Data.Edit import qualified Data.Map as Map import Data.Sum (Apply (..), Sum) import qualified Data.Text as Text @@ -57,6 +58,11 @@ instance ToJSONFields Span where instance ToJSONFields Loc where toJSONFields Loc{..} = toJSONFields byteRange <> toJSONFields span +instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Edit a b) where + toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] + toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] + toJSONFields (Compare a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] + newtype JSONFields a = JSONFields { unJSONFields :: a } diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs deleted file mode 100644 index 952de6abf..000000000 --- a/src/Data/Patch.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Data.Patch -( Patch(..) -, after -, before -, patch -) where - -import Prologue -import Data.Aeson -import Data.Align -import Data.JSON.Fields - --- | An operation to replace, insert, or delete an item. -data Patch a b - = Delete a - | Insert b - | Replace a b - deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable) - - --- | Return the item from the after side of the patch. -after :: Patch before after -> Maybe after -after = patch (const Nothing) Just (\ _ b -> Just b) - --- | Return the item from the before side of the patch. -before :: Patch before after -> Maybe before -before = patch Just (const Nothing) (\ a _ -> Just a) - --- | Return both sides of a patch. -patch :: (before -> result) -> (after -> result) -> (before -> after -> result) -> Patch before after -> result -patch ifDelete _ _ (Delete a) = ifDelete a -patch _ ifInsert _ (Insert b) = ifInsert b -patch _ _ ifReplace (Replace a b) = ifReplace a b - - --- Instances - -instance Bifunctor Patch where - bimap f _ (Delete a) = Delete (f a) - bimap _ g (Insert b) = Insert (g b) - bimap f g (Replace a b) = Replace (f a) (g b) - -instance Bifoldable Patch where - bifoldMap f _ (Delete a) = f a - bifoldMap _ g (Insert b) = g b - bifoldMap f g (Replace a b) = f a `mappend` g b - -instance Bitraversable Patch where - bitraverse f _ (Delete a) = Delete <$> f a - bitraverse _ g (Insert b) = Insert <$> g b - bitraverse f g (Replace a b) = Replace <$> f a <*> g b - -instance Bicrosswalk Patch where - bicrosswalk f _ (Delete a) = Delete <$> f a - bicrosswalk _ g (Insert b) = Insert <$> g b - bicrosswalk f g (Replace a b) = alignWith (these Delete Insert Replace) (f a) (g b) - -instance Eq2 Patch where - liftEq2 eqBefore eqAfter p1 p2 = case (p1, p2) of - (Delete a1, Delete a2) -> eqBefore a1 a2 - (Insert b1, Insert b2) -> eqAfter b1 b2 - (Replace a1 b1, Replace a2 b2) -> eqBefore a1 a2 && eqAfter b1 b2 - _ -> False - -instance Show2 Patch where - liftShowsPrec2 spBefore _ spAfter _ d p = case p of - Delete a -> showsUnaryWith spBefore "Delete" d a - Insert b -> showsUnaryWith spAfter "Insert" d b - Replace a b -> showsBinaryWith spBefore spAfter "Replace" d a b - - -instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Patch a b) where - toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ] - toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ] - toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ] diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 97c1fc30c..994049521 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -35,16 +35,26 @@ projectExtensions = extensionsForLanguage . projectLanguage projectFiles :: Project -> [File] projectFiles = fmap blobFile . projectBlobs -readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProjectFromPaths :: MonadIO m + => Maybe Path.AbsRelDir -- ^ An optional root directory for the project + -> Path.AbsRelFileDir -- ^ A file or directory to parse. Passing a file path loads all files in that file's parent directory. + -> Language + -> [Path.AbsRelDir] -- ^ Directories to exclude. + -> m Project readProjectFromPaths maybeRoot path lang excludeDirs = do - isDir <- isDirectory path - let rootDir = if isDir - then fromMaybe path maybeRoot - else fromMaybe (takeDirectory path) maybeRoot + let rootDir :: Path.AbsRelDir + rootDir = case maybeRoot >>= Path.fromAbsRel of + -- If we were provided a root directory, use that. + Just root -> root + Nothing -> case Path.fileFromFileDir path of + -- If we weren't and the path is a file, drop its file name. + Just fp -> Path.takeDirectory fp + -- Otherwise, load from the path. + Nothing -> Path.dirFromFileDir path - paths <- liftIO $ findFilesInDir (Path.absRel rootDir) exts (fmap Path.absRel excludeDirs) + paths <- liftIO $ findFilesInDir rootDir exts excludeDirs blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths - pure $ Project rootDir blobs lang excludeDirs + pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs) where toFile path = File (Path.toString path) lang exts = extensionsForLanguage lang diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 0c166d8f9..6eff484f5 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -216,9 +216,7 @@ instance Evaluatable Class where currentScope' <- currentScope superScopes <- for classSuperclasses $ \superclass -> do - name <- case declaredName superclass of - Just name -> pure name - Nothing -> gensym + name <- maybeM gensym (declaredName superclass) scope <- associatedScope (Declaration name) slot <- lookupSlot (Declaration name) superclassFrame <- scopedEnvironment =<< deref slot diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 3f8e9c1d0..eeb5d942d 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -3,7 +3,7 @@ module Data.Syntax.Expression where import Prelude hiding (null) -import Prologue hiding (This, index, null) +import Prologue hiding (index, null) import Control.Abstract hiding (Bitwise (..), Call, Member) import Data.Abstract.Evaluatable as Abstract hiding (Member) diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index ea23cb983..391daade9 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -5,7 +5,7 @@ module Diffing.Algorithm , Diffable (..) , Equivalence (..) , diff - , diffThese + , diffEdit , diffMaybe , linearly , byReplacing @@ -17,6 +17,7 @@ module Diffing.Algorithm import Control.Effect.Carrier hiding ((:+:)) import Control.Effect.NonDet import qualified Data.Diff as Diff +import qualified Data.Edit as Edit import Data.Sum import Data.Term import GHC.Generics @@ -53,9 +54,9 @@ instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff diff a1 a2 = send (Diff a1 a2 pure) --- | Diff a These of terms without specifying the algorithm to be used. -diffThese :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => These term1 term2 -> Algorithm term1 term2 diff m diff -diffThese = these byDeleting byInserting diff +-- | Diff an 'Edit.Edit' of terms without specifying the algorithm to be used. +diffEdit :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Edit.Edit term1 term2 -> Algorithm term1 term2 diff m diff +diffEdit = Edit.edit byDeleting byInserting diff -- | Diff a pair of optional terms without specifying the algorithm to be used. diffMaybe :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff) @@ -143,8 +144,8 @@ class Diffable f where -> Algorithm term1 term2 diff m (f diff) algorithmFor = genericAlgorithmFor - tryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) - default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) + tryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) + default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) tryAlignWith f a b = to1 <$> gtryAlignWith f (from1 a) (from1 b) -- | Construct an algorithm to diff against positions inside an @f@. @@ -207,30 +208,30 @@ instance Apply Diffable fs => Diffable (Sum fs) where instance Diffable Maybe where algorithmFor = diffMaybe - tryAlignWith f (Just a1) (Just a2) = Just <$> f (These a1 a2) - tryAlignWith f (Just a1) Nothing = Just <$> f (This a1) - tryAlignWith f Nothing (Just a2) = Just <$> f (That a2) + tryAlignWith f (Just a1) (Just a2) = Just <$> f (Edit.Compare a1 a2) + tryAlignWith f (Just a1) Nothing = Just <$> f (Edit.Delete a1) + tryAlignWith f Nothing (Just a2) = Just <$> f (Edit.Insert a2) tryAlignWith _ Nothing Nothing = pure Nothing -- | Diff two lists using RWS. instance Diffable [] where algorithmFor = byRWS - tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (These a1 a2) <*> tryAlignWith f as1 as2 - tryAlignWith f [] as2 = traverse (f . That) as2 - tryAlignWith f as1 [] = traverse (f . This) as1 + tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2 + tryAlignWith f [] as2 = traverse (f . Edit.Insert) as2 + tryAlignWith f as1 [] = traverse (f . Edit.Delete) as1 -- | Diff two non-empty lists using RWS. instance Diffable NonEmpty where algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty - tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2 + tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2 -- | A generic type class for diffing two terms defined by the Generic1 interface. class GDiffable f where galgorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) - gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) + gtryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) gcomparableTo :: f term1 -> f term2 -> Bool gcomparableTo _ _ = True @@ -271,7 +272,7 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where instance GDiffable Par1 where galgorithmFor (Par1 a1) (Par1 a2) = Par1 <$> diff a1 a2 - gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (These a b) + gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (Edit.Compare a b) -- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants). -- i.e. data Foo = Foo Int (the 'Int' is a constant parameter). diff --git a/src/Diffing/Algorithm/RWS.hs b/src/Diffing/Algorithm/RWS.hs index 65dda81a9..c705353b5 100644 --- a/src/Diffing/Algorithm/RWS.hs +++ b/src/Diffing/Algorithm/RWS.hs @@ -15,7 +15,8 @@ module Diffing.Algorithm.RWS ) where import Control.Monad.State.Strict -import Data.Diff (DiffF(..), deleting, inserting, merge, replacing) +import Data.Diff (DiffF(..), comparing, deleting, inserting, merge) +import Data.Edit import qualified Data.KdMap.Static as KdMap import Data.List (sortOn) import Data.Term as Term @@ -37,7 +38,7 @@ rws :: (Foldable syntax, Functor syntax, Diffable syntax) -> [Edit (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))] rws _ _ as [] = Delete <$> as rws _ _ [] bs = Insert <$> bs -rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [Copy a b] else [Insert b, Delete a] +rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [Compare a b] else [Insert b, Delete a] rws canCompare equivalent as bs = ses equivalent as bs & mapContiguous [] [] @@ -46,15 +47,15 @@ rws canCompare equivalent as bs -- Map contiguous sequences of unmapped terms separated by SES-mapped equivalencies. mapContiguous as bs [] = mapSimilar (reverse as) (reverse bs) mapContiguous as bs (first : rest) = case first of - Delete a -> mapContiguous (a : as) bs rest - Insert b -> mapContiguous as (b : bs) rest - Copy _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest) + Delete a -> mapContiguous (a : as) bs rest + Insert b -> mapContiguous as (b : bs) rest + Compare _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest) -- Map comparable, mutually similar terms, inserting & deleting surrounding terms. mapSimilar as' bs' = go as bs where go as [] = Delete . snd <$> as go [] bs = Insert . snd <$> bs - go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Copy (snd a) (snd b)] + go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Compare (snd a) (snd b)] | otherwise = [Insert (snd b), Delete (snd a)] go as@((i, _) : _) ((j, b) : restB) = fromMaybe (Insert b : go as restB) $ do @@ -66,7 +67,7 @@ rws canCompare equivalent as bs guard (j == j') -- Delete any elements of as before the selected element. let (deleted, _ : restA) = span ((< i') . fst) as - pure $! (Delete . snd <$> deleted) <> (Copy a b : go restA restB) + pure $! (Delete . snd <$> deleted) <> (Compare a b : go restA restB) (as, bs) = (zip [0..] as', zip [0..] bs') (kdMapA, kdMapB) = (toKdMap as, toKdMap bs) @@ -158,7 +159,7 @@ editDistanceUpTo m a b = diffCost m (approximateDiff a b) _ | m <= 0 -> 0 Merge body -> sum (fmap ($ pred m) body) body -> succ (sum (fmap ($ pred m) body)) - approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b)) + approximateDiff a b = maybe (comparing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . edit deleting inserting approximateDiff) (termOut a) (termOut b)) data Label syntax where diff --git a/src/Diffing/Algorithm/SES.hs b/src/Diffing/Algorithm/SES.hs index 581256066..067120436 100644 --- a/src/Diffing/Algorithm/SES.hs +++ b/src/Diffing/Algorithm/SES.hs @@ -1,35 +1,13 @@ -{-# LANGUAGE BangPatterns, GADTs, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns, GADTs, MultiParamTypeClasses, ScopedTypeVariables #-} module Diffing.Algorithm.SES -( Edit(..) -, toThese -, ses +( ses ) where import Data.Array ((!)) import qualified Data.Array as Array -import Data.Bifunctor +import Data.Edit import Data.Foldable (find, toList) import Data.Ix -import Data.These - --- | An edit script, i.e. a sequence of changes/copies of elements. -data Edit a b - = Delete a - | Insert b - | Copy a b - deriving (Eq, Functor, Ord, Show) - -instance Bifunctor Edit where - bimap f g = \case - Delete a -> Delete (f a) - Insert b -> Insert (g b) - Copy a b -> Copy (f a) (g b) - -toThese :: Edit a b -> These a b -toThese = \case - Delete a -> This a - Insert b -> That b - Copy a b -> These a b data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: [Edit a b] } deriving (Eq, Show) @@ -78,11 +56,11 @@ ses eq as' bs' slideFrom (Endpoint x y script) | Just a <- as !? x , Just b <- bs !? y - , a `eq` b = slideFrom (Endpoint (succ x) (succ y) (Copy a b : script)) + , a `eq` b = slideFrom (Endpoint (succ x) (succ y) (Compare a b : script)) | otherwise = Endpoint x y script (!?) :: Ix i => Array.Array i a -> i -> Maybe a -(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a - | otherwise = Nothing +v !? i | inRange (Array.bounds v) i, !a <- v ! i = Just a + | otherwise = Nothing {-# INLINE (!?) #-} diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index e4d3a01d1..8857eff15 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -9,10 +9,10 @@ import Control.Effect.Carrier import Control.Effect.Cull import Control.Effect.NonDet import qualified Data.Diff as Diff +import Data.Edit (Edit, edit) import Data.Term import Diffing.Algorithm import Diffing.Algorithm.RWS -import Diffing.Algorithm.SES (toThese) import Prologue -- | Diff two à la carte terms recursively. @@ -20,7 +20,7 @@ diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Term syntax ann1 -> Term syntax ann2 -> Diff.Diff syntax ann1 ann2 -diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2'))))) +diffTerms t1 t2 = stripDiff (fromMaybe (Diff.comparing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2'))))) where (t1', t2') = ( defaultFeatureVectorDecorator t1 , defaultFeatureVectorDecorator t2) @@ -37,12 +37,12 @@ class Bifoldable (DiffFor term) => DiffTerms term where -- Note that the dependency means that the diff type is in 1:1 correspondence with the term type. This allows subclasses of 'DiffTerms' to receive e.g. @'DiffFor' term a b@ without incurring ambiguity, since every diff type is unique to its term type. type DiffFor term = (diff :: * -> * -> *) | diff -> term - -- | Diff a 'These' of terms. - diffTermPair :: These (term ann1) (term ann2) -> DiffFor term ann1 ann2 + -- | Diff an 'Edit' of terms. + diffTermPair :: Edit (term ann1) (term ann2) -> DiffFor term ann1 ann2 instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where type DiffFor (Term syntax) = Diff.Diff syntax - diffTermPair = these Diff.deleting Diff.inserting diffTerms + diffTermPair = edit Diff.deleting Diff.inserting diffTerms -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. @@ -71,10 +71,10 @@ instance ( Alternative m (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig) (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where eff (L op) = case op of - Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k - Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k - RWS as bs k -> traverse (runDiff . diffThese . toThese) (rws comparableTerms equivalentTerms as bs) >>= k + Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.comparing t1 t2) >>= k + Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffEdit) f1 f2 >>= k + RWS as bs k -> traverse (runDiff . diffEdit) (rws comparableTerms equivalentTerms as bs) >>= k Delete a k -> k (Diff.deleting a) Insert b k -> k (Diff.inserting b) - Replace a b k -> k (Diff.replacing a b) + Replace a b k -> k (Diff.comparing a b) eff (R other) = DiffC . eff . handleCoercible $ other diff --git a/src/Prologue.hs b/src/Prologue.hs index 8e18e082e..c0590ee6c 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -16,7 +16,6 @@ import Data.Bits as X import Data.ByteString as X (ByteString) import Data.Coerce as X import Data.Int as X (Int8, Int16, Int32, Int64) -import Data.Functor.Both as X (Both (Both), runBothWith) import Data.Either as X (fromLeft, fromRight) import Data.IntMap as X (IntMap) import Data.IntSet as X (IntSet) @@ -30,7 +29,6 @@ import Data.Semilattice.Lower as X (Lower(..)) import Data.Set as X (Set) import Data.Sum as X (Sum, Element, Elements, (:<), (:<:), Apply (..), inject) import Data.Text as X (Text) -import Data.These as X import Data.Word as X (Word8, Word16, Word32, Word64) import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, throwIO, throwTo) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 4c9215318..5994c724f 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -14,8 +14,8 @@ import Control.Effect.Reader import Control.Effect.State import Control.Lens import Data.Diff +import Data.Edit import Data.Graph -import Data.Patch import Data.ProtoLens (defMessage) import Data.String (IsString (..)) import Data.Term @@ -99,7 +99,7 @@ instance (ConstructorName syntax, Foldable syntax) => Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 . DiffTreeVertex'Inserted $ defMessage & P.term .~ T.pack (constructorName syntax) & P.maybe'span .~ ann a2 - Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do + Patch (Compare t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do i <- fresh parent <- ask let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1) diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs index 39dd4f0e7..e2486c880 100644 --- a/src/Rendering/JSON.hs +++ b/src/Rendering/JSON.hs @@ -15,9 +15,8 @@ module Rendering.JSON import Data.Aeson (ToJSON, toJSON, object, (.=)) import Data.Aeson as A -import Data.JSON.Fields import Data.Blob -import Data.Patch +import Data.JSON.Fields import Data.Text (pack) import GHC.TypeLits import Prologue @@ -56,8 +55,8 @@ newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair } deriving (Eq, Show) instance ToJSON JSONStat where - 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)))) + toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs) + toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs)) -- | Render a term to a value representing its JSON. renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index d6b03188c..6033afc03 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -12,13 +12,12 @@ module Rendering.TOC import Prologue hiding (index) import Analysis.TOCSummary -import Data.Align (bicrosswalk) import Data.Aeson (ToJSON(..), Value, (.=), object) import Data.Diff +import Data.Edit import Data.Language as Language import Data.List (sortOn) import qualified Data.Map.Monoidal as Map -import Data.Patch import Data.Term import qualified Data.Text as T import Source.Loc @@ -77,12 +76,17 @@ tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f ann ann -- ^ The diff to compute the table of contents for. -> [(Change, a)] -- ^ A list of entries for relevant changed nodes in the diff. -tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of - Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just [] +tableOfContentsBy selector = fromMaybe [] . cata (\case + Patch edit -> (pure . patchEntry <$> select (bimap selector selector edit)) <> bifoldMap fold fold edit <> Just [] Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of (Just a, Just entries) -> Just ((Changed, a) : entries) (_ , entries) -> entries) - where patchEntry = patch (Deleted,) (Inserted,) (const (Replaced,)) + where patchEntry = edit (Deleted,) (Inserted,) (const (Replaced,)) + + select = \case + Delete a -> Delete <$> a + Insert b -> Insert <$> b + Compare a b -> liftA2 Compare a b <|> Delete <$> a <|> Insert <$> b data DedupeKey = DedupeKey !Kind {-# UNPACK #-} !T.Text diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 3b7d702b3..e66361d6d 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -46,10 +46,10 @@ type DomainC term address value m -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. evaluate :: ( Carrier outerSig outer , derefSig ~ (Deref value :+: allocatorSig) - , derefC ~ (DerefC address value allocatorC) + , derefC ~ DerefC address value allocatorC , Carrier derefSig derefC , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) - , allocatorC ~ (AllocatorC address (ReaderC ModuleInfo outer)) + , allocatorC ~ AllocatorC address (ReaderC ModuleInfo outer) , Carrier allocatorSig allocatorC , Effect outerSig , Member Fresh outerSig diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index dee30b8ea..1c3c66c19 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, LambdaCase #-} +{-# LANGUAGE FunctionalDependencies #-} module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) @@ -7,6 +7,7 @@ module Semantic.Api.Bridge import Control.Lens import qualified Data.Blob as Data +import qualified Data.Edit as Data import qualified Data.Language as Data import Data.ProtoLens (defMessage) import qualified Data.Text as T @@ -78,11 +79,11 @@ instance APIConvert API.BlobPair Data.BlobPair where converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where apiBlobPairToBlobPair blobPair = case (blobPair^.maybe'before, blobPair^.maybe'after) of - (Just before, Just after) -> Just $ Data.Diffing (before^.bridging) (after^.bridging) - (Just before, Nothing) -> Just $ Data.Deleting (before^.bridging) - (Nothing, Just after) -> Just $ Data.Inserting (after^.bridging) + (Just before, Just after) -> Just $ Data.Compare (before^.bridging) (after^.bridging) + (Just before, Nothing) -> Just $ Data.Delete (before^.bridging) + (Nothing, Just after) -> Just $ Data.Insert (after^.bridging) _ -> Nothing - blobPairToApiBlobPair (Data.Diffing before after) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ (bridging #? after) - blobPairToApiBlobPair (Data.Inserting after) = defMessage & P.maybe'before .~ Nothing & P.maybe'after .~ (bridging #? after) - blobPairToApiBlobPair (Data.Deleting before) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ Nothing + blobPairToApiBlobPair (Data.Compare before after) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ (bridging #? after) + blobPairToApiBlobPair (Data.Insert after) = defMessage & P.maybe'before .~ Nothing & P.maybe'after .~ (bridging #? after) + blobPairToApiBlobPair (Data.Delete before) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ Nothing diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index bfbf0b0d2..582cd11c4 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -18,6 +18,7 @@ import Control.Lens import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder +import Data.Edit import Data.Graph import Data.JSON.Fields import Data.Language @@ -156,9 +157,9 @@ diffWith diffWith parsers render = parsePairWith parsers (render <=< diffTerms) diffTerms :: (DiffTerms term, Member Telemetry sig, Carrier sig m, MonadIO m) - => These (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann) + => Edit (Blob, term ann) (Blob, term ann) -> m (DiffFor term ann ann) diffTerms terms = time "diff" languageTag $ do let diff = diffTermPair (bimap snd snd terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs - blobs = BlobPair (bimap fst fst terms) + blobs = bimap fst fst terms diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 2d51aef97..484045c38 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -18,6 +18,7 @@ import Control.Monad.IO.Class import Data.Aeson import Data.Blob import Data.ByteString.Builder +import Data.Edit import Data.Either (partitionEithers) import Data.Function (on) import Data.Functor.Classes @@ -30,7 +31,6 @@ import Data.ProtoLens (defMessage) import Data.Semilattice.Lower import Data.Term (Term) import qualified Data.Text as T -import Data.These (These, fromThese) import Diffing.Algorithm (Diffable) import qualified Diffing.Algorithm.SES as SES import qualified Language.Java as Java @@ -107,7 +107,7 @@ summarizeDiffParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeDi summarizeDiffParsers = allParsers class SummarizeDiff term where - summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => These (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] + summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where summarizeTerms = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where @@ -123,16 +123,16 @@ deriving via (ViaTags Python.Term) instance SummarizeDiff Python.Term newtype ViaTags t a = ViaTags (t a) instance Tagging.ToTags t => SummarizeDiff (ViaTags t) where - summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . uncurry (SES.ses compare) . fromThese [] [] . bimap (uncurry go) (uncurry go) $ terms where + summarizeTerms terms = pure . map (uncurry summarizeChange) . dedupe . mapMaybe toChange . edit (map Delete) (map Insert) (SES.ses compare) . bimap (uncurry go) (uncurry go) $ terms where go blob (ViaTags t) = Tagging.tags (blobSource blob) t - lang = languageForBlobPair (BlobPair (bimap fst fst terms)) - (s1, s2) = fromThese mempty mempty (bimap (blobSource . fst) (blobSource . fst) terms) + lang = languageForBlobPair (bimap fst fst terms) + (s1, s2) = edit (,mempty) (mempty,) (,) (bimap (blobSource . fst) (blobSource . fst) terms) compare = liftA2 (&&) <$> ((==) `on` Tag.kind) <*> ((==) `on` Tag.name) toChange = \case - SES.Delete tag -> (Deleted,) <$> toDecl tag - SES.Insert tag -> (Inserted,) <$> toDecl tag - SES.Copy t1 t2 + Delete tag -> (Deleted,) <$> toDecl tag + Insert tag -> (Inserted,) <$> toDecl tag + Compare t1 t2 | Source.slice s1 (byteRange (Tag.loc t1)) /= Source.slice s2 (byteRange (Tag.loc t2)) -> (Changed,) <$> toDecl t2 | otherwise -> Nothing diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 57e5687ee..ba2bab166 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -6,7 +6,6 @@ import Control.Effect.Reader import Control.Exception as Exc (displayException) import Data.Blob import Data.Blob.IO -import qualified Data.ByteString.Char8 as B import Data.Handle import qualified Data.Language as Language import Data.List (intercalate) @@ -18,7 +17,6 @@ import Semantic.Api hiding (File) import Semantic.Config import qualified Semantic.Graph as Graph import qualified Semantic.Task as Task -import qualified Semantic.Git as Git import Semantic.Task.Files import Semantic.Telemetry import qualified Semantic.Telemetry.Log as Log @@ -99,7 +97,7 @@ diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute change <|> flag' (diffSummaryBuilder JSON) (long "toc" <> help "Output JSON table of contents diff summary") <|> flag' (parseDiffBuilder DiffDotGraph) (long "dot" <> help "Output the diff as a DOT graph") <|> flag' (parseDiffBuilder DiffShow) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") - filesOrStdin <- Right <$> some (Both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin) + filesOrStdin <- Right <$> some ((,) <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin) pure $ Task.readBlobPairs filesOrStdin >>= runReader languageModes . renderer parseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder) @@ -134,14 +132,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa <|> flag' (parseTermBuilder TermQuiet) ( long "quiet" <> help "Don't produce output, but show timing stats") - filesOrStdin <- FilesFromGitRepo - <$> option str (long "gitDir" <> help "A .git directory to read from") - <*> option shaReader (long "sha" <> help "The commit SHA1 to read from") - <*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude")) - <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin") - <|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths")) - <|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin")) - <|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES...")) + filesOrStdin <- FilesFromPaths <$> some (argument filePathReader (metavar "FILES...")) <|> pure (FilesFromHandle stdin) pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer @@ -169,9 +160,9 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g _ -> pure $! Project "/" mempty Language.Unknown mempty readProjectRecursively = makeReadProjectRecursivelyTask <$> option auto (long "language" <> help "The language for the analysis.") - <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) - <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) - <*> argument str (metavar "DIR") + <*> optional (pathOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) + <*> many (pathOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) + <*> argument path (metavar "PATH") makeReadProjectRecursivelyTask language rootDir excludeDirs dir = Task.readProject rootDir dir language excludeDirs makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer @@ -183,12 +174,6 @@ languageModes = Language.PerLanguageModes <> value Language.ALaCarte <> showDefault) -shaReader :: ReadM Git.OID -shaReader = eitherReader parseSha - where parseSha arg = if length arg == 40 || arg == "HEAD" - then Right (Git.OID (B.pack arg)) - else Left (arg <> " is not a valid sha1") - filePathReader :: ReadM File filePathReader = fileForPath <$> str diff --git a/src/Semantic/Git.hs b/src/Semantic/Git.hs deleted file mode 100644 index bae25e994..000000000 --- a/src/Semantic/Git.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Semantic.Git - ( -- Primary (partial) API for cmd line git - clone - , lsTree - , catFile - - -- Intermediate datatypes - , TreeEntry(..) - , ObjectType(..) - , ObjectMode(..) - , OID(..) - - -- Testing Purposes - , parseEntries - , parseEntry - ) where - -import Prologue - -import Data.Attoparsec.ByteString (Parser) -import Data.Attoparsec.ByteString as AP -import Data.ByteString (ByteString) -import Data.ByteString.Internal (w2c) -import qualified Data.ByteString.UTF8 as UTF8 -import qualified Data.ByteString.Streaming as ByteStream -import qualified Data.Attoparsec.ByteString.Streaming as AP.Streaming -import Data.Char -import Data.Either (fromRight) -import Data.Text as Text -import Text.Parser.Combinators (sepEndBy) -import qualified Streaming.Process -import qualified System.Process as Process -import qualified Source.Source as Source - --- | git clone --bare -clone :: Text -> FilePath -> IO () -clone url path = Process.callProcess "git" - ["clone", "--bare", Text.unpack url, path] - --- | Runs @git cat-file -p@. Throws 'ProcessExitedUnsuccessfully' if the --- underlying git command returns a nonzero exit code. Loads the contents --- of the file into memory all at once and strictly. -catFile :: FilePath -> OID -> IO Source.Source -catFile gitDir (OID oid) = - let process = Process.proc "git" ["-C", gitDir, "cat-file", "-p", UTF8.toString oid] - consumeStdout stream = Streaming.Process.withProcessOutput stream ByteStream.toStrict_ - in Source.fromUTF8 <$> Streaming.Process.withStreamProcess process consumeStdout - --- | git ls-tree -rz -lsTree :: FilePath -> OID -> IO [TreeEntry] -lsTree gitDir (OID sha) = - let process = Process.proc "git" ["-C", gitDir, "ls-tree", "-rz", UTF8.toString sha] - allEntries = (entryParser `sepEndBy` AP.word8 0) <* AP.endOfInput - ignoreFailures = fmap (fromRight [] . fst) - in Streaming.Process.withStreamProcess process $ - \stream -> Streaming.Process.withProcessOutput stream (ignoreFailures . AP.Streaming.parse allEntries) - - --- | Parses an list of entries separated by \NUL, and on failure return [] -parseEntries :: ByteString -> [TreeEntry] -parseEntries = fromRight [] . AP.parseOnly everything - where - everything = AP.sepBy entryParser (AP.word8 0) - --- | Parse the entire input with entryParser, and on failure return a default --- For testing purposes only -parseEntry :: ByteString -> Either String TreeEntry -parseEntry = AP.parseOnly (entryParser <* AP.endOfInput) - --- | Parses a TreeEntry -entryParser :: Parser TreeEntry -entryParser = TreeEntry - <$> modeParser <* AP.word8 space - <*> typeParser <* AP.word8 space - <*> oidParser <* AP.word8 tab - <*> (UTF8.toString <$> AP.takeWhile (/= nul)) - where - char = fromIntegral @Int @Word8 . ord - space = char ' ' - tab = char '\t' - nul = char '\NUL' - typeParser = AP.choice [BlobObject <$ "blob", TreeObject <$ "tree", OtherObjectType <$ AP.takeWhile (isAlphaNum . w2c)] - modeParser = AP.choice [NormalMode <$ "100644", ExecutableMode <$ "100755", SymlinkMode <$ "120000", TreeMode <$ "040000", OtherMode <$ AP.takeWhile (isAlphaNum . w2c)] - oidParser = OID <$> AP.takeWhile (isHexDigit . w2c) - -newtype OID = OID ByteString - deriving (Eq, Show, Ord) - -data ObjectMode - = NormalMode - | ExecutableMode - | SymlinkMode - | TreeMode - | OtherMode - deriving (Eq, Show) - -data ObjectType - = BlobObject - | TreeObject - | OtherObjectType - deriving (Eq, Show) - -data TreeEntry - = TreeEntry - { treeEntryMode :: ObjectMode - , treeEntryType :: ObjectType - , treeEntryOid :: OID - , treeEntryPath :: FilePath - } deriving (Eq, Show) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 351296fbc..5ee650b0a 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, - ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} + ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Task ( TaskC , Level(..) diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 222e45479..092c07011 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -14,7 +14,6 @@ module Semantic.Task.Files , Handle (..) , FilesC(..) , FilesArg(..) - , PathFilter(..) ) where import Control.Effect.Carrier @@ -28,7 +27,6 @@ import Data.Language import Data.Project import Prelude hiding (readFile) import Prologue hiding (catch) -import qualified Semantic.Git as Git import Semantic.IO import qualified System.IO as IO hiding (withBinaryFile) import qualified System.Path.IO as IO (withBinaryFile) @@ -38,22 +36,15 @@ data Source blob where FromPath :: File -> Source Blob FromHandle :: Handle 'IO.ReadMode -> Source [Blob] FromDir :: Path.AbsRelDir -> Source [Blob] - FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob] - FromPathPair :: Both File -> Source BlobPair + FromPathPair :: File -> File -> Source BlobPair FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode) -data PathFilter - = ExcludePaths [FilePath] - | ExcludeFromHandle (Handle 'IO.ReadMode) - | IncludePaths [FilePath] - | IncludePathsFromHandle (Handle 'IO.ReadMode) - -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's. data Files (m :: * -> *) k = forall a . Read (Source a) (a -> m k) - | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> m k) + | ReadProject (Maybe Path.AbsRelDir) Path.AbsRelFileDir Language [Path.AbsRelDir] (Project -> m k) | FindFiles Path.AbsRelDir [String] [Path.AbsRelDir] ([Path.AbsRelFile] -> m k) | Write Destination B.Builder (m k) @@ -84,11 +75,7 @@ instance (Member (Error SomeException) sig, Member Catch sig, MonadIO m, Carrier Read (FromPath path) k -> rethrowing (readBlobFromFile' path) >>= k Read (FromHandle handle) k -> rethrowing (readBlobsFromHandle handle) >>= k Read (FromDir dir) k -> rethrowing (readBlobsFromDir dir) >>= k - Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths mempty) >>= k - Read (FromGitRepo path sha (ExcludeFromHandle handle)) k -> rethrowing (readPathsFromHandle handle >>= (\x -> readBlobsFromGitRepo path sha x mempty)) >>= k - Read (FromGitRepo path sha (IncludePaths includePaths)) k -> rethrowing (readBlobsFromGitRepo path sha mempty includePaths) >>= k - Read (FromGitRepo path sha (IncludePathsFromHandle h)) k -> rethrowing (readPathsFromHandle h >>= readBlobsFromGitRepo path sha mempty) >>= k - Read (FromPathPair paths) k -> rethrowing (runBothWith readFilePair paths) >>= k + Read (FromPathPair p1 p2) k -> rethrowing (readFilePair p1 p2) >>= k Read (FromPairHandle handle) k -> rethrowing (readBlobPairsFromHandle handle) >>= k ReadProject rootDir dir language excludeDirs k -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k FindFiles dir exts excludeDirs k -> rethrowing (findFilesInDir dir exts excludeDirs) >>= k @@ -102,7 +89,6 @@ readBlob file = send (Read (FromPath file) pure) data FilesArg = FilesFromHandle (Handle 'IO.ReadMode) | FilesFromPaths [File] - | FilesFromGitRepo FilePath Git.OID PathFilter -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. readBlobs :: (Member Files sig, Carrier sig m, MonadIO m) => FilesArg -> m [Blob] @@ -113,14 +99,13 @@ readBlobs (FilesFromPaths [path]) = do then send (Read (FromDir (Path.path (filePath path))) pure) else pure <$> send (Read (FromPath path) pure) readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths -readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure) -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair] +readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair] readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure) -readBlobPairs (Right paths) = traverse (send . flip Read pure . FromPathPair) paths +readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths -readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project +readProject :: (Member Files sig, Carrier sig m) => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure) findFiles :: (Member Files sig, Carrier sig m) => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile] diff --git a/src/Serializing/SExpression.hs b/src/Serializing/SExpression.hs index 96d94f0b1..7681fabe5 100644 --- a/src/Serializing/SExpression.hs +++ b/src/Serializing/SExpression.hs @@ -8,7 +8,7 @@ module Serializing.SExpression import Analysis.ConstructorName import Data.ByteString.Builder import Data.Diff -import Data.Patch +import Data.Edit import Data.Term import Prelude import Prologue @@ -43,6 +43,6 @@ instance (ConstructorName syntax, Foldable syntax, Show ann1, Show ann2) => ToSE toSExpression options diff n = case diff of Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> namedBranch options term n <> "-}" Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> namedBranch options term n <> "+}" - Patch (Replace term1 term2) -> nl n <> pad (n - 1) <> "{ " <> namedBranch options term1 n + Patch (Compare term1 term2) -> nl n <> pad (n - 1) <> "{ " <> namedBranch options term1 n <> nl (n + 1) <> pad (n - 1) <> "->" <> namedBranch options term2 n <> " }" Merge term -> nl n <> pad n <> namedBranch options term n diff --git a/src/Serializing/SExpression/Precise.hs b/src/Serializing/SExpression/Precise.hs index ae2cf6b21..70238e405 100644 --- a/src/Serializing/SExpression/Precise.hs +++ b/src/Serializing/SExpression/Precise.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Serializing.SExpression.Precise ( serializeSExpression , ToSExpression(..) diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index c5d8eb516..b90174df2 100644 --- a/src/Tags/Taggable.hs +++ b/src/Tags/Taggable.hs @@ -12,7 +12,7 @@ identify a new syntax as Taggable, you need to: constructor name of this syntax. -} -{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, KindSignatures, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Tags.Taggable ( Tagger , Token(..) diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index ae2d22e2c..4b06f0855 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -57,12 +57,11 @@ contextualizing :: ( Member (State [ContextToken]) sig contextualizing source toKind = Streaming.mapMaybeM $ \case Enter x r -> Nothing <$ enterScope (x, r) Exit x r -> Nothing <$ exitScope (x, r) - Iden iden loc docsLiteralRange -> get @[ContextToken] >>= pure . \case - ((x, r):("Context", cr):_) | Just kind <- toKind x - -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr)) - ((x, r):_) | Just kind <- toKind x - -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange) - _ -> Nothing + Iden iden loc docsLiteralRange -> fmap go (get @[ContextToken]) where + go = \case + ((x, r):("Context", cr):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (Just (slice cr)) + ((x, r):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine (slice r)) (slice <$> docsLiteralRange) + _ -> Nothing where slice = stripEnd . Source.toText . Source.slice source firstLine = T.take 180 . fst . breakOn "\n" diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index d42f76fdc..ebc943c26 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -20,10 +20,9 @@ import qualified Analysis.TOCSummary as ToC import Data.Abstract.ScopeGraph (AccessControl(..)) import Data.Bifunctor.Join import Data.Diff -import Data.Functor.Both +import Data.Edit import qualified Data.Language as Language import Data.List.NonEmpty -import Data.Patch import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration @@ -122,9 +121,6 @@ instance Listable1 NonEmpty where instance Listable2 p => Listable1 (Join p) where liftTiers tiers = liftCons1 (liftTiers2 tiers tiers) Join -instance Listable1 Both where - liftTiers tiers = liftCons2 tiers tiers Both - instance Listable1 f => Listable2 (TermF f) where liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) In @@ -160,10 +156,10 @@ instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff synt tiers = tiers2 -instance Listable2 Patch where - liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Replace +instance Listable2 Edit where + liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Compare -instance (Listable a, Listable b) => Listable (Patch a b) where +instance (Listable a, Listable b) => Listable (Edit a b) where tiers = tiers2 diff --git a/test/Diffing/Algorithm/RWS/Spec.hs b/test/Diffing/Algorithm/RWS/Spec.hs index 0e88dada1..0569b2998 100644 --- a/test/Diffing/Algorithm/RWS/Spec.hs +++ b/test/Diffing/Algorithm/RWS/Spec.hs @@ -7,11 +7,9 @@ import Data.Functor.Listable (ListableSyntax) import Data.Sum import qualified Data.Syntax as Syntax import Data.Term -import Data.These import Diffing.Algorithm (comparableTerms) import Diffing.Interpreter (stripDiff) import Diffing.Algorithm.RWS -import Diffing.Algorithm.SES import Diffing.Interpreter.Spec (afterTerm, beforeTerm) import Test.Hspec.LeanCheck import SpecHelpers @@ -31,16 +29,16 @@ spec = do \ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax ()]) tbs = decorate <$> (bs :: [Term ListableSyntax ()]) wrap = termIn emptyAnnotation . inject - diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffThese . toThese <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in + diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffEdit <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in (beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs))) it "produces unbiased insertions within branches" $ let (a, b) = (decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "a")) ])), decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "b")) ]))) in - fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Copy b b ] + fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Compare b b ] where decorate = defaultFeatureVectorDecorator - diffThese = these deleting inserting replacing + diffEdit = edit deleting inserting comparing stripTerm :: Functor f => Term f (FeatureVector, ()) -> Term f () stripTerm = fmap snd diff --git a/test/Diffing/Algorithm/SES/Spec.hs b/test/Diffing/Algorithm/SES/Spec.hs index 79b48aad0..53e136475 100644 --- a/test/Diffing/Algorithm/SES/Spec.hs +++ b/test/Diffing/Algorithm/SES/Spec.hs @@ -1,6 +1,6 @@ module Diffing.Algorithm.SES.Spec (spec) where -import Data.These +import Data.Edit import Diffing.Algorithm.SES import Test.Hspec import Test.Hspec.LeanCheck @@ -8,17 +8,17 @@ import Test.Hspec.LeanCheck spec :: Spec spec = do describe "ses" $ do - prop "returns equal lists in These" $ - \ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Copy as as + prop "returns equal lists in Compare" $ + \ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Compare as as - prop "returns deletions in This" $ + prop "returns deletions in Delete" $ \ as -> (ses (==) as [] :: [Edit Char Char]) `shouldBe` fmap Delete as - prop "returns insertions in That" $ + prop "returns insertions in Insert" $ \ bs -> (ses (==) [] bs :: [Edit Char Char]) `shouldBe` fmap Insert bs prop "returns all elements individually for disjoint inputs" $ \ as bs -> length (ses (==) ((,) 0 <$> as :: [(Int, Char)]) ((,) 1 <$> bs :: [(Int, Char)])) `shouldBe` length as + length bs prop "is lossless w.r.t. both input elements & ordering" $ - \ as bs -> foldr (\ each (as, bs) -> these (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) (toThese each)) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs) + \ as bs -> foldr (\ each (as, bs) -> edit (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) each) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs) diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index a040fd002..56d59145e 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/test/Diffing/Interpreter/Spec.hs @@ -8,17 +8,15 @@ import Data.Functor.Foldable (cata) import Data.Functor.Listable import Data.Maybe import Data.Mergeable -import Data.Patch (after, before) import Data.Sum import Data.Term -import Data.These import Diffing.Interpreter import qualified Data.Syntax as Syntax import Test.Hspec (Spec, describe, it) import Test.Hspec.Expectations import Test.Hspec.LeanCheck import Test.LeanCheck.Core -import SpecHelpers () +import SpecHelpers (Edit(..), edit) spec :: Spec spec = do @@ -26,7 +24,7 @@ spec = do it "returns a replacement when comparing two unicode equivalent terms" $ let termA = termIn emptyAnnotation (inject (Syntax.Identifier "t\776")) termB = termIn emptyAnnotation (inject (Syntax.Identifier "\7831")) in - diffTerms termA termB `shouldBe` replacing termA (termB :: Term ListableSyntax ()) + diffTerms termA termB `shouldBe` comparing termA (termB :: Term ListableSyntax ()) prop "produces correct diffs" $ \ a b -> let diff = diffTerms a b :: Diff ListableSyntax () () in @@ -61,11 +59,11 @@ spec = do describe "diffTermPair" $ do prop "produces an Insert when the first term is missing" $ do - \ after -> let diff = diffTermPair (That after) :: Diff ListableSyntax () () in + \ after -> let diff = diffTermPair (Insert after) :: Diff ListableSyntax () () in diff `shouldBe` inserting after prop "produces a Delete when the second term is missing" $ do - \ before -> let diff = diffTermPair (This before) :: Diff ListableSyntax () () in + \ before -> let diff = diffTermPair (Delete before) :: Diff ListableSyntax () () in diff `shouldBe` deleting before @@ -81,5 +79,13 @@ afterTerm = cata $ \ diff -> case diff of Patch patch -> (after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum) Merge (In (_, b) r) -> termIn b <$> sequenceAlt r +-- | Return the item from the after side of the patch. +after :: Edit l r -> Maybe r +after = edit (const Nothing) Just (\ _ b -> Just b) + +-- | Return the item from the before side of the patch. +before :: Edit l r -> Maybe l +before = edit Just (const Nothing) (\ a _ -> Just a) + emptyAnnotation :: () emptyAnnotation = () diff --git a/test/Integration/Spec.hs b/test/Integration/Spec.hs index 5eb79e8bb..29c317ef1 100644 --- a/test/Integration/Spec.hs +++ b/test/Integration/Spec.hs @@ -39,7 +39,7 @@ testForExample = \case ("diffs " <> Path.toString diffOutput) (\ref new -> ["git", "diff", ref, new]) (Path.toString diffOutput) - (BL.fromStrict <$> diffFilePaths ?session (Both fileA fileB)) + (BL.fromStrict <$> diffFilePaths ?session fileA fileB) ParseExample{file, parseOutput} -> goldenVsStringDiff ("parses " <> Path.toString parseOutput) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 10de55ffd..7e091df89 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -8,7 +8,6 @@ import Data.Aeson hiding (defaultOptions) import Data.Bifunctor import Data.Diff import Data.Either (isRight) -import Data.Patch import Data.Sum import Data.Term import Data.Text (Text) @@ -37,9 +36,9 @@ spec = do \ term -> tableOfContentsBy (Just . termFAnnotation) (diffTerms term (term :: Term ListableSyntax ())) `shouldBe` [] prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $ - \ p -> tableOfContentsBy (Just . termFAnnotation) (patch deleting inserting replacing p) + \ p -> tableOfContentsBy (Just . termFAnnotation) (edit deleting inserting comparing p) `shouldBe` - patch (fmap (Deleted,)) (fmap (Inserted,)) (\ as bs -> (Replaced, head bs) : fmap (Deleted,) (tail as) <> fmap (Inserted,) (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term ListableSyntax Int) (Term ListableSyntax Int))) + edit (fmap (Deleted,)) (fmap (Inserted,)) (\ as bs -> (Replaced, head bs) : fmap (Deleted,) (tail as) <> fmap (Inserted,) (tail bs)) (bimap (foldMap pure) (foldMap pure) (p :: Edit (Term ListableSyntax Int) (Term ListableSyntax Int))) prop "produces changed entries for relevant nodes containing irrelevant patches" $ \ diff -> do @@ -53,7 +52,7 @@ spec = do diffTOC blankDiff `shouldBe` [ ] it "summarizes changed methods" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) + sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "self")) "self.foo" (Span (Pos 1 1) (Pos 2 4)) Inserted @@ -62,37 +61,37 @@ spec = do ] it "dedupes changes in same parent method" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js")) + sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/duplicate-parent.A.js") (Path.relFile "javascript/toc/duplicate-parent.B.js") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "myFunction" (Span (Pos 1 1) (Pos 6 2)) Changed ] it "dedupes similar methods" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js")) + sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/erroneous-duplicate-method.A.js") (Path.relFile "javascript/toc/erroneous-duplicate-method.B.js") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary Function "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) Replaced ] it "summarizes Go methods with receivers with special formatting" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go")) + sourceBlobs <- blobsForPaths (Path.relFile "go/toc/method-with-receiver.A.go") (Path.relFile "go/toc/method-with-receiver.B.go") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method (Just "*apiClient")) "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) Inserted ] it "summarizes Ruby methods that start with two identifiers" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb")) + sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/method-starts-with-two-identifiers.A.rb") (Path.relFile "ruby/toc/method-starts-with-two-identifiers.B.rb") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 1 1) (Pos 4 4)) Changed ] it "handles unicode characters in file" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb")) + sourceBlobs <- blobsForPaths (Path.relFile "ruby/toc/unicode.A.rb") (Path.relFile "ruby/toc/unicode.B.rb") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [ Right $ TOCSummary (Method Nothing) "foo" (Span (Pos 6 1) (Pos 7 4)) Inserted ] it "properly slices source blob that starts with a newline and has multi-byte chars" $ do - sourceBlobs <- blobsForPaths (Both (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js")) + sourceBlobs <- blobsForPaths (Path.relFile "javascript/toc/starts-with-newline.js") (Path.relFile "javascript/toc/starts-with-newline.js") diff <- runTaskOrDie $ summarize sourceBlobs diff `shouldBe` [] @@ -135,22 +134,22 @@ spec = do describe "diff with ToCDiffRenderer'" $ do it "produces JSON output" $ do - blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb")) + blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.B.rb") output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs])) runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"self.foo\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"ADDED\"},{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":6,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}]}]}\n" :: ByteString) it "produces JSON output if there are parse errors" $ do - blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb")) + blobs <- blobsForPaths (Path.relFile "ruby/toc/methods.A.rb") (Path.relFile "ruby/toc/methods.X.rb") output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs])) runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\",\"language\":\"Ruby\",\"changes\":[{\"category\":\"Method\",\"term\":\"bar\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":4}},\"changeType\":\"REMOVED\"},{\"category\":\"Method\",\"term\":\"baz\",\"span\":{\"start\":{\"line\":4,\"column\":1},\"end\":{\"line\":5,\"column\":4}},\"changeType\":\"REMOVED\"}],\"errors\":[{\"error\":\"expected end of input nodes, but got ParseError\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":2,\"column\":3}}}]}]}\n" :: ByteString) it "ignores anonymous functions" $ do - blobs <- blobsForPaths (Both (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb")) + blobs <- blobsForPaths (Path.relFile "ruby/toc/lambda.A.rb") (Path.relFile "ruby/toc/lambda.B.rb") output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs])) runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/ruby/toc/lambda.A.rb -> test/fixtures/ruby/toc/lambda.B.rb\",\"language\":\"Ruby\"}]}\n" :: ByteString) it "summarizes Markdown headings" $ do - blobs <- blobsForPaths (Both (Path.relFile "markdown/toc/headings.A.md") (Path.relFile "markdown/toc/headings.B.md")) + blobs <- blobsForPaths (Path.relFile "markdown/toc/headings.A.md") (Path.relFile "markdown/toc/headings.B.md") output <- runTaskOrDie (runReader defaultLanguageModes (diffSummaryBuilder Format.JSON [blobs])) runBuilder output `shouldBe` ("{\"files\":[{\"path\":\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\",\"language\":\"Markdown\",\"changes\":[{\"category\":\"Heading 1\",\"term\":\"Introduction\",\"span\":{\"start\":{\"line\":1,\"column\":1},\"end\":{\"line\":3,\"column\":16}},\"changeType\":\"REMOVED\"},{\"category\":\"Heading 2\",\"term\":\"Two\",\"span\":{\"start\":{\"line\":5,\"column\":1},\"end\":{\"line\":7,\"column\":4}},\"changeType\":\"MODIFIED\"},{\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"span\":{\"start\":{\"line\":9,\"column\":1},\"end\":{\"line\":11,\"column\":10}},\"changeType\":\"ADDED\"},{\"category\":\"Heading 1\",\"term\":\"Final\",\"span\":{\"start\":{\"line\":13,\"column\":1},\"end\":{\"line\":14,\"column\":4}},\"changeType\":\"ADDED\"}]}]}\n" :: ByteString) @@ -161,14 +160,14 @@ type Term' = Term ListableSyntax (Maybe Declaration) numTocSummaries :: Diff' -> Int numTocSummaries diff = length $ filter isRight (diffTOC diff) --- Return a diff where body is inserted in the expressions of a function. The function is present in Both sides of the diff. +-- Return a diff where body is inserted in the expressions of a function. The function is present in both sides of the diff. programWithChange :: Term' -> Diff' programWithChange body = merge (Nothing, Nothing) (inject [ function' ]) where function' = merge (Just (Declaration Function "foo" lowerBound Ruby), Just (Declaration Function "foo" lowerBound Ruby)) (inject (Declaration.Function [] name' [] (merge (Nothing, Nothing) (inject [ inserting body ])))) name' = merge (Nothing, Nothing) (inject (Syntax.Identifier (name "foo"))) --- Return a diff where term is inserted in the program, below a function found on Both sides of the diff. +-- Return a diff where term is inserted in the program, below a function found on both sides of the diff. programWithChangeOutsideFunction :: Term' -> Diff' programWithChangeOutsideFunction term = merge (Nothing, Nothing) (inject [ function', term' ]) where @@ -183,7 +182,7 @@ programWithDelete :: Text -> Term' -> Diff' programWithDelete name body = programOf $ deleting (functionOf name body) programWithReplace :: Text -> Term' -> Diff' -programWithReplace name body = programOf $ replacing (functionOf name body) (functionOf (name <> "2") body) +programWithReplace name body = programOf $ comparing (functionOf name body) (functionOf (name <> "2") body) programOf :: Diff' -> Diff' programOf diff = merge (Nothing, Nothing) (inject [ diff ]) @@ -208,8 +207,9 @@ isMethodOrFunction a | any isJust (foldMap (:[]) a) = True | otherwise = False -blobsForPaths :: Both Path.RelFile -> IO BlobPair -blobsForPaths = readFilePathPair . fmap (Path.relDir "test/fixtures" ) +blobsForPaths :: Path.RelFile -> Path.RelFile -> IO BlobPair +blobsForPaths p1 p2 = readFilePathPair (prefix p1) (prefix p2) where + prefix = (Path.relDir "test/fixtures" ) blankDiff :: Diff' blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject (Syntax.Identifier (name "\"a\"")))) ]) diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 7d5c7d800..c95b6c1e7 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -34,7 +34,7 @@ renderDiff ref new = unsafePerformIO $ do else ["git", "diff", ref, new] {-# NOINLINE renderDiff #-} -testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile) -> TestTree +testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile) -> TestTree testForDiffFixture (diffRenderer, runDiff, files, expected) = goldenVsStringDiff ("diff fixture renders to " <> diffRenderer <> " " <> show files) @@ -65,12 +65,12 @@ parseFixtures = prefix = Path.relDir "test/fixtures/cli" run = runReader (PerLanguageModes ALaCarte) -diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [Both File], Path.RelFile)] +diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile)] diffFixtures = [ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix Path.file "diff-tree.json") , ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt") , ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix Path.file "diff-tree.toc.json") , ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix Path.file "diff-tree.toc.protobuf.bin") ] - where pathMode = [Both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" Ruby)] + where pathMode = [(File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby, File "test/fixtures/ruby/corpus/method-declaration.B.rb" Ruby)] prefix = Path.relDir "test/fixtures/cli" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index eb10de200..c3e76c624 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -4,86 +4,12 @@ module Semantic.IO.Spec (spec) where import Prelude hiding (readFile) -import Control.Monad.IO.Class -import Data.List -import Data.String -import qualified Data.Text as Text -import System.Directory -import System.IO.Temp - import Data.Blob import Data.Handle -import qualified Semantic.Git as Git -import Shelly (cd, run_, shelly, silently, touchfile, writefile) -import qualified Source.Source as Source import SpecHelpers -import System.Path (()) -import qualified System.Path as Path - - -makeGitRepo :: FilePath -> IO () -makeGitRepo dir = shelly . silently $ do - cd (fromString dir) - let git = run_ "git" - git ["init"] - touchfile "bar.py" - writefile "日本語.rb" "# coding: utf-8\n日本語 = 'hello'" - git ["add", "日本語.rb", "bar.py"] - git ["config", "user.name", "'Test'"] - git ["config", "user.email", "'test@test.test'"] - git ["commit", "-am", "'test commit'"] spec :: Spec spec = do - describe "catFile" $ do - hasGit <- runIO $ isJust <$> findExecutable "git" - when hasGit . it "should not corrupt the output of files with UTF-8 identifiers" $ do - result <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - makeGitRepo dir - trees <- Git.lsTree (dir <> "/.git") (Git.OID "HEAD") - Just it <- pure $ find (\p -> "日本語" `isInfixOf` Git.treeEntryPath p) trees - Git.catFile (dir <> "/.git") (Git.treeEntryOid it) - Source.toText result `shouldSatisfy` ("日本語" `Text.isInfixOf`) - - describe "lsTree" $ do - hasGit <- runIO $ isJust <$> findExecutable "git" - when hasGit . it "should read all tree entries from a repo" $ do - items <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - makeGitRepo dir - Git.lsTree dir (Git.OID "HEAD") - - length items `shouldBe` 2 - - describe "readBlobsFromGitRepo" $ do - hasGit <- runIO $ isJust <$> findExecutable "git" - when hasGit . it "should read from a git directory" $ do - -- This temporary directory will be cleaned after use. - blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - makeGitRepo dir - readBlobsFromGitRepoPath (Path.absDir dir Path.relDir ".git") (Git.OID "HEAD") [] [] - let files = sortOn fileLanguage (blobFile <$> blobs) - files `shouldBe` [ File "bar.py" Python - , File "日本語.rb" Ruby - ] - - when hasGit . it "should read from a git directory with --only" $ do - -- This temporary directory will be cleaned after use. - blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - let pdir = Path.absDir dir - makeGitRepo dir - readBlobsFromGitRepoPath (pdir Path.relDir ".git") (Git.OID "HEAD") [] [Path.relFile "日本語.rb"] - let files = sortOn fileLanguage (blobFile <$> blobs) - files `shouldBe` [ File "日本語.rb" Ruby ] - - when hasGit . it "should read from a git directory with --exclude" $ do - -- This temporary directory will be cleaned after use. - blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do - makeGitRepo dir - - readBlobsFromGitRepoPath (Path.absDir dir Path.relDir ".git") (Git.OID "HEAD") [Path.relFile "日本語.rb"] [] - let files = sortOn fileLanguage (blobFile <$> blobs) - files `shouldBe` [ File "bar.py" Python ] - describe "readFile" $ do it "returns a blob for extant files" $ do Just blob <- readBlobFromFile (File "semantic.cabal" Unknown) @@ -97,34 +23,34 @@ spec = do let b = sourceBlob "method.rb" Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" - blobs `shouldBe` [Diffing a b] + blobs `shouldBe` [Compare a b] it "returns blobs when there's no before" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json" - blobs `shouldBe` [Inserting b] + blobs `shouldBe` [Insert b] it "returns blobs when there's null before" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json" - blobs `shouldBe` [Inserting b] + blobs `shouldBe` [Insert b] it "returns blobs when there's no after" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json" - blobs `shouldBe` [Deleting a] + blobs `shouldBe` [Delete a] it "returns blobs when there's null after" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json" - blobs `shouldBe` [Deleting a] + blobs `shouldBe` [Delete 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` [Inserting b'] + blobs `shouldBe` [Insert b'] it "detects language based on filepath for empty language" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json" - blobs `shouldBe` [Diffing a b] + blobs `shouldBe` [Compare a b] it "throws on blank input" $ do h <- openFileForReading "test/fixtures/cli/blank.json" diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 90728fd9d..c5b42d89f 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -6,7 +6,6 @@ import SpecHelpers import Data.Blob (NoLanguageForBlob (..)) import Semantic.Api hiding (Blob) -import Semantic.Git -- we need some lenses here, oof setBlobLanguage :: Language -> Blob -> Blob @@ -15,6 +14,8 @@ setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }} spec :: Spec spec = do describe "parseBlob" $ do + let methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty + it "returns error if given an unknown language (json)" $ do output <- fmap runBuilder . runTaskOrDie . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob \\\"methods.rb\\\"\",\"language\":\"Unknown\"}]}\n" @@ -28,27 +29,3 @@ spec = do it "renders with the specified renderer" $ do output <- fmap runBuilder . runTaskOrDie . runReader (PerLanguageModes ALaCarte) $ parseTermBuilder TermSExpression [methodsBlob] output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n" - - describe "git ls-tree parsing" $ do - it "parses a git output string" $ do - let input = "100644 tree abcdef\t/this/is/the/path" - let expected = Right $ TreeEntry NormalMode TreeObject (OID "abcdef") "/this/is/the/path" - parseEntry input `shouldBe` expected - - it "allows whitespace in the path" $ do - let input = "100644 tree 12345\t/this\n/is\t/the /path\r" - let expected = Right $ TreeEntry NormalMode TreeObject (OID "12345") "/this\n/is\t/the /path\r" - parseEntry input `shouldBe` expected - - it "parses many outputs separated by \\NUL" $ do - let input = "100644 tree abcdef\t/this/is/the/path\NUL120000 blob 17776\t/dev/urandom\NUL\n" - let expected = [ TreeEntry NormalMode TreeObject (OID "abcdef") "/this/is/the/path", TreeEntry SymlinkMode BlobObject (OID "17776") "/dev/urandom"] - parseEntries input `shouldBe` expected - - it "parses submodules and other types" $ do - let input = "160000 commit 50865e8895c54037bf06c4c1691aa925d030a59d\tgemoji" - let expected = Right $ TreeEntry OtherMode OtherObjectType (OID "50865e8895c54037bf06c4c1691aa925d030a59d") "gemoji" - parseEntry input `shouldBe` expected - - where - methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 4e965f23e..1a9f5873e 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -60,7 +60,7 @@ import Source.Span as X hiding (HasSpan(..), start, end, point) import Debug.Trace as X (traceShowM, traceM) import Data.ByteString as X (ByteString) -import Data.Functor.Both as X (Both (Both), runBothWith) +import Data.Edit as X import Data.Maybe as X import Data.Monoid as X (Monoid(..), First(..), Last(..)) import Data.Semigroup as X (Semigroup(..)) @@ -87,11 +87,11 @@ instance IsString Name where fromString = X.name . fromString -- | Returns an s-expression formatted diff for the specified FilePath pair. -diffFilePaths :: TaskSession -> Both Path.RelFile -> IO ByteString -diffFilePaths session paths - = readFilePathPair paths - >>= runTask session . runParse (configTreeSitterParseTimeout (config session)) . parseDiffBuilder @[] DiffSExpression . pure - >>= either (die . displayException) (pure . runBuilder) +diffFilePaths :: TaskSession -> Path.RelFile -> Path.RelFile -> IO ByteString +diffFilePaths session p1 p2 = do + blobs <- readFilePathPair p1 p2 + builder <- runTask session (runParse (configTreeSitterParseTimeout (config session)) (parseDiffBuilder DiffSExpression [ blobs ])) + either (die . displayException) (pure . runBuilder) builder -- | Returns an s-expression parse tree for the specified path. parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString) @@ -104,9 +104,8 @@ runParseWithConfig :: (Carrier sig m, Member (Reader Config) sig) => ParseC m a runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task -- | Read two files to a BlobPair. -readFilePathPair :: Both Path.RelFile -> IO BlobPair -readFilePathPair paths = let paths' = fmap fileForTypedPath paths in - runBothWith readFilePair paths' +readFilePathPair :: Path.RelFile -> Path.RelFile -> IO BlobPair +readFilePathPair p1 p2 = readFilePair (fileForTypedPath p1) (fileForTypedPath p2) parseTestFile :: Parser term -> Path.RelFile -> IO (Blob, term) parseTestFile parser path = runTaskOrDie $ do