github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 00:42:33 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'look-up-its-a-core' into compile-string-literals

Browse Source
This commit is contained in:
Patrick Thomson 2019-10-23 14:52:29 -04:00
commit edd83d466f
55 changed files with 373 additions and 660 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
.hlint.yaml
View File

@ -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

6
.travis.yml
View File

@ -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

9
semantic-core/src/Core/Core.hs
View File

@ -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)

7
semantic-core/src/Core/Eval.hs
View File

@ -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

9
semantic-core/src/Core/Parser.hs
View File

@ -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

1
semantic-core/src/Core/Pretty.hs
View File

@ -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)

1
semantic-core/test/Generators.hs
View File

@ -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..=)
]

14
semantic-python/src/Prelude.score
View File

@ -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 }
}

4
semantic-python/test/Directive.hs
View File

@ -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

2
semantic-python/test/Instances.hs
View File

@ -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

11
semantic.cabal
View File

@ -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

20
src/Control/Abstract/Value.hs
View File

@ -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)

2
src/Control/Carrier/Parse/Simple.hs
View File

@ -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

6
src/Control/Effect/Parse.hs
View File

@ -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
@ -52,10 +52,10 @@ parseWith parsers with blob = case Map.lookup (blobLanguage blob) parsers of
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@.
-> (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

61
src/Data/Blob.hs
View File

@ -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]

27
src/Data/Blob/IO.hs
View File

@ -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

28
src/Data/Diff.hs
View File

@ -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)
-- | 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)
-- | 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

71
src/Data/Edit.hs Normal file
View File

@ -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

23
src/Data/Functor/Both.hs
View File

@ -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

3
src/Data/ImportPath.hs
View File

@ -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
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

6
src/Data/JSON/Fields.hs
View File

@ -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 }

76
src/Data/Patch.hs
View File

@ -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)] ]

24
src/Data/Project.hs
View File

@ -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

4
src/Data/Syntax/Declaration.hs
View File

@ -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

2
src/Data/Syntax/Expression.hs
View File

@ -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)

31
src/Diffing/Algorithm.hs
View File

@ -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).

13
src/Diffing/Algorithm/RWS.hs
View File

@ -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 [] []
@ -48,13 +49,13 @@ rws canCompare equivalent as 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)
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

32
src/Diffing/Algorithm/SES.hs
View File

@ -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
v !? i | inRange (Array.bounds v) i, !a <- v ! i = Just a
| otherwise = Nothing
{-# INLINE (!?) #-}

18
src/Diffing/Interpreter.hs
View File

@ -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

2
src/Prologue.hs
View File

@ -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)

4
src/Rendering/Graph.hs
View File

@ -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)

7
src/Rendering/JSON.hs
View File

@ -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

14
src/Rendering/TOC.hs
View File

@ -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

4
src/Semantic/Analysis.hs
View File

@ -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

15
src/Semantic/Api/Bridge.hs
View File

@ -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

5
src/Semantic/Api/Diffs.hs
View File

@ -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

16
src/Semantic/Api/TOCSummaries.hs
View File

@ -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

25
src/Semantic/CLI.hs
View File

@ -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

109
src/Semantic/Git.hs
View File

@ -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)

2
src/Semantic/Task.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures,
ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( TaskC
, Level(..)

27
src/Semantic/Task/Files.hs
View File

@ -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]

4
src/Serializing/SExpression.hs
View File

@ -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

2
src/Serializing/SExpression/Precise.hs
View File

@ -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(..)

2
src/Tags/Taggable.hs
View File

@ -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(..)

9
src/Tags/Tagging.hs
View File

@ -57,11 +57,10 @@ 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)
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

12
test/Data/Functor/Listable.hs
View File

@ -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

8
test/Diffing/Algorithm/RWS/Spec.hs
View File

@ -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

12
test/Diffing/Algorithm/SES/Spec.hs
View File

@ -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)

18
test/Diffing/Interpreter/Spec.hs
View File

@ -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 = ()

2
test/Integration/Spec.hs
View File

@ -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)

38
test/Rendering/TOC/Spec.hs
View File

@ -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\"")))) ])

6
test/Semantic/CLI/Spec.hs
View File

@ -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"

88
test/Semantic/IO/Spec.hs
View File

@ -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<String>) {\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"

27
test/Semantic/Spec.hs
View File

@ -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

17
test/SpecHelpers.hs
View File

@ -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