diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs index a3ca78d66..fdcecb740 100644 --- a/src/Assigning/Assignment.hs +++ b/src/Assigning/Assignment.hs @@ -218,7 +218,7 @@ nodeError expected Node{..} = Error nodeSpan expected (Just (Right nodeSymbol)) firstSet :: (Enum grammar, Ix grammar) => Assignment ast grammar a -> [grammar] -firstSet = iterFreer (\ (Tracing _ assignment) _ -> case assignment of +firstSet = iterFreer (\ _ (Tracing _ assignment) -> case assignment of Choose table _ _ -> Table.tableAddresses table Label child _ -> firstSet child _ -> []) . ([] <$) @@ -245,11 +245,11 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha go assignment = iterFreer run ((pure .) . (,) <$> assignment) {-# INLINE go #-} - run :: Tracing (AssignmentF ast grammar) x - -> (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar)) + run :: (x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar)) + -> Tracing (AssignmentF ast grammar) x -> State ast grammar -> Either (Error (Either String grammar)) (result, State ast grammar) - run t yield initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) + run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) where atNode (Term (In node f)) = case runTracing t of Location -> yield (nodeLocation node) state CurrentNode -> yield (In node (() <$ f)) state @@ -367,7 +367,7 @@ instance (Enum grammar, Eq1 ast, Ix grammar, Show grammar) => MonadError (Error throwError err = fail (show err) catchError :: HasCallStack => Assignment ast grammar a -> (Error (Either String grammar) -> Assignment ast grammar a) -> Assignment ast grammar a - catchError rule handler = iterFreer (\ (Tracing cs assignment) continue -> case assignment of + catchError rule handler = iterFreer (\ continue (Tracing cs assignment) -> case assignment of Choose choices atEnd Nothing -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler)) `Then` return Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` return _ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index a1beae60f..f90536478 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -1,56 +1,62 @@ module Data.Blob ( Blob(..) -, BlobKind(..) -, modeToDigits -, defaultPlainBlob -, emptyBlob , nullBlob -, blobExists , sourceBlob -, nullOid +, BlobPair +, These(..) +, blobPairDiffing +, blobPairInserting +, blobPairDeleting +, languageForBlobPair +, languageTagForBlobPair +, pathForBlobPair ) where -import Data.ByteString.Char8 (ByteString, pack) +import Data.Bifunctor.Join import Data.Language -import Data.Maybe (isJust) +import Data.These import Data.Source as Source -import Data.Word -import Numeric --- | The source, oid, path, and Maybe BlobKind of a blob. + +-- | The source, path, and language of a blob. data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. - , blobOid :: ByteString -- ^ The Git object ID (SHA-1) of the blob. , blobPath :: FilePath -- ^ The file path to the blob. - , blobKind :: Maybe BlobKind -- ^ The kind of blob, Nothing denotes a blob that doesn't exist (e.g. on one side of a diff for adding a new file or deleting a file). , blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet. } deriving (Show, Eq) --- | The kind and file mode of a 'Blob'. -data BlobKind = PlainBlob Word32 | ExecutableBlob Word32 | SymlinkBlob Word32 - deriving (Show, Eq) - -modeToDigits :: BlobKind -> ByteString -modeToDigits (PlainBlob mode) = pack $ showOct mode "" -modeToDigits (ExecutableBlob mode) = pack $ showOct mode "" -modeToDigits (SymlinkBlob mode) = pack $ showOct mode "" - --- | The default plain blob mode -defaultPlainBlob :: BlobKind -defaultPlainBlob = PlainBlob 0o100644 - -emptyBlob :: FilePath -> Blob -emptyBlob filepath = Blob mempty nullOid filepath Nothing Nothing - nullBlob :: Blob -> Bool -nullBlob Blob{..} = blobOid == nullOid || nullSource blobSource - -blobExists :: Blob -> Bool -blobExists Blob{..} = isJust blobKind +nullBlob Blob{..} = nullSource blobSource sourceBlob :: FilePath -> Maybe Language -> Source -> Blob -sourceBlob filepath language source = Blob source nullOid filepath (Just defaultPlainBlob) language +sourceBlob filepath language source = Blob source filepath language -nullOid :: ByteString -nullOid = "0000000000000000000000000000000000000000" + +-- | 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. +type BlobPair = Join These Blob + + +blobPairDiffing :: Blob -> Blob -> BlobPair +blobPairDiffing a b = Join (These a b) + +blobPairInserting :: Blob -> BlobPair +blobPairInserting = Join . That + +blobPairDeleting :: Blob -> BlobPair +blobPairDeleting = Join . This + +languageForBlobPair :: BlobPair -> Maybe Language +languageForBlobPair (Join (This Blob{..})) = blobLanguage +languageForBlobPair (Join (That Blob{..})) = blobLanguage +languageForBlobPair (Join (These _ Blob{..})) = blobLanguage + +pathForBlobPair :: BlobPair -> FilePath +pathForBlobPair (Join (This Blob{..})) = blobPath +pathForBlobPair (Join (That Blob{..})) = blobPath +pathForBlobPair (Join (These _ Blob{..})) = blobPath + +languageTagForBlobPair :: BlobPair -> [(String, String)] +languageTagForBlobPair pair = maybe [] showLanguage (languageForBlobPair pair) + where showLanguage = pure . (,) "language" . show diff --git a/src/Data/Error.hs b/src/Data/Error.hs index 13dc2dea7..f07756aab 100644 --- a/src/Data/Error.hs +++ b/src/Data/Error.hs @@ -39,7 +39,7 @@ type Colourize = Bool formatError :: IncludeSource -> Colourize -> Blob -> Error String -> String formatError includeSource colourize Blob{..} Error{..} = ($ "") - $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan (maybe Nothing (const (Just blobPath)) blobKind) errorSpan . showString ": ") + $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan (Just blobPath) errorSpan . showString ": ") . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n' . (if includeSource then showString (unpack context) . (if "\n" `isSuffixOf` context then id else showChar '\n') diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 8a609e79c..b2ec67a73 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -75,7 +75,7 @@ runAlgorithm comparable eqTerms = go (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) result -> m result - go = iterFreerA (\ step yield -> case step of + go = iterFreerA (\ yield step -> case step of Diffing.Algorithm.Diff t1 t2 -> go (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield Linear (Term (In ann1 f1)) (Term (In ann2 f2)) -> merge (ann1, ann2) <$> galignWith (go . diffThese) f1 f2 >>= yield RWS as bs -> traverse (go . diffThese) (rws comparable eqTerms as bs) >>= yield diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs index fb99231a9..41cd0cf5c 100644 --- a/src/Rendering/JSON.hs +++ b/src/Rendering/JSON.hs @@ -4,26 +4,20 @@ module Rendering.JSON ) where import Data.Aeson (ToJSON, toJSON, object, (.=)) -import Data.Aeson as A hiding (json) +import Data.Aeson as A import Data.Blob -import Data.Foldable (toList) -import Data.Functor.Both (Both) +import Data.Bifoldable (biList) +import Data.Bifunctor.Join import Data.Language import qualified Data.Map as Map import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) import GHC.Generics --- --- Diffs --- - -- | Render a diff to a string representing its JSON. -renderJSONDiff :: ToJSON a => Both Blob -> a -> Map.Map Text Value +renderJSONDiff :: ToJSON a => BlobPair -> a -> Map.Map Text Value renderJSONDiff blobs diff = Map.fromList [ ("diff", toJSON diff) - , ("oids", toJSON (decodeUtf8 . blobOid <$> toList blobs)) - , ("paths", toJSON (blobPath <$> toList blobs)) + , ("paths", toJSON (blobPath <$> (biList . runJoin) blobs)) ] data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileContent :: a } @@ -32,5 +26,6 @@ data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileC instance ToJSON a => ToJSON (File a) where toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ] +-- | Render a term to a string representing its JSON. renderJSONTerm :: ToJSON a => Blob -> a -> [Value] renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 772af46f5..9f5f0ee31 100644 --- a/src/Rendering/TOC.hs +++ b/src/Rendering/TOC.hs @@ -21,17 +21,17 @@ import Data.Aeson import Data.Align (bicrosswalk) import Data.Bifoldable (bifoldMap) import Data.Bifunctor (bimap) +import Data.Bifunctor.Join import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Diff import Data.Foldable (fold, foldl') -import Data.Functor.Both hiding (fst, snd) import Data.Functor.Foldable (cata) import Data.Function (on) import Data.Language as Language import Data.List (sortOn) import qualified Data.List as List -import qualified Data.Map as Map hiding (null) +import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) import Data.Output import Data.Patch @@ -160,15 +160,15 @@ recordSummary changeText record = case getDeclaration record of formatIdentifier (MethodDeclaration identifier _ _ (Just receiver)) = receiver <> "." <> identifier formatIdentifier declaration = declarationIdentifier declaration -renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries +renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => BlobPair -> Diff f (Record fields) (Record fields) -> Summaries renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC where toMap [] = mempty toMap as = Map.singleton summaryKey (toJSON <$> as) - summaryKey = T.pack $ case runJoin (blobPath <$> blobs) of - (before, after) | null before -> after - | null after -> before - | before == after -> after - | otherwise -> before <> " -> " <> after + summaryKey = T.pack $ case bimap blobPath blobPath (runJoin blobs) of + This before -> before + That after -> after + These before after | before == after -> after + | otherwise -> before <> " -> " <> after diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [TOCSummary] diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration diff --git a/src/Semantic.hs b/src/Semantic.hs index daf7af36e..649c63b7b 100644 --- a/src/Semantic.hs +++ b/src/Semantic.hs @@ -16,10 +16,10 @@ import Control.Monad ((>=>), guard) import Control.Monad.Error.Class import Data.Align.Generic import Data.Bifoldable +import Data.Bifunctor.Join import Data.Blob import Data.ByteString (ByteString) import Data.Diff -import Data.Functor.Both as Both import Data.Functor.Classes import Data.JSON.Fields import qualified Data.Language as Language @@ -45,7 +45,7 @@ import Semantic.Task as Task -- - Easy to consume this interface from other application (e.g a cmdline or web server app). parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString -parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . filter blobExists +parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) -- | A task to parse a 'Blob' and render the resulting 'Term'. parseBlob :: TermRenderer output -> Blob -> Task output @@ -70,11 +70,11 @@ data NoParserForLanguage = NoParserForLanguage FilePath (Maybe Language.Language deriving (Eq, Exception, Ord, Show, Typeable) -diffBlobPairs :: Output output => DiffRenderer output -> [Both Blob] -> Task ByteString -diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair renderer) . filter (any blobExists) +diffBlobPairs :: Output output => DiffRenderer output -> [BlobPair] -> Task ByteString +diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair renderer) -- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'. -diffBlobPair :: DiffRenderer output -> Both Blob -> Task output +diffBlobPair :: DiffRenderer output -> BlobPair -> Task output diffBlobPair renderer blobs | Just (SomeParser parser) <- effectiveLanguage >>= qualify >>= someParser (Proxy :: Proxy '[ConstructorName, IdentifierName, Diffable, Eq1, GAlign, HasDeclaration, Show1, ToJSONFields1, Traversable]) = case renderer of @@ -91,10 +91,8 @@ diffBlobPair renderer blobs SExpressionDiffRenderer -> run ( parse parser >=> pure . fmap keepCategory) diffSyntaxTerms (const renderSExpressionDiff) | otherwise = throwError (SomeException (NoParserForLanguage effectivePath effectiveLanguage)) - where (effectivePath, effectiveLanguage) = case runJoin blobs of - (Blob { blobLanguage = Just lang, blobPath = path }, _) -> (path, Just lang) - (_, Blob { blobLanguage = Just lang, blobPath = path }) -> (path, Just lang) - (Blob { blobPath = path }, _) -> (path, Nothing) + where effectiveLanguage = languageForBlobPair blobs + effectivePath = pathForBlobPair blobs qualify language | OldToCDiffRenderer <- renderer = guard (language `elem` aLaCarteLanguages) *> Just language | otherwise = Just language @@ -108,24 +106,21 @@ diffBlobPair renderer blobs , Language.TypeScript ] - run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Both Blob -> Diff syntax ann ann -> output) -> Task output + run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Join These Blob -> Diff syntax ann ann -> output) -> Task output run parse diff renderer = do - terms <- distributeFor blobs parse + terms <- bidistributeFor (runJoin blobs) parse parse time "diff" languageTag $ do - diff <- runBothWith (diffTermPair blobs diff) terms + diff <- diffTermPair diff terms writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) render (renderer blobs) diff where - showLanguage = pure . (,) "language" . show - languageTag = let (a, b) = runJoin blobs - in maybe (maybe [] showLanguage (blobLanguage b)) showLanguage (blobLanguage a) + languageTag = languageTagForBlobPair blobs --- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. -diffTermPair :: Functor syntax => Both Blob -> Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) -diffTermPair blobs differ t1 t2 = case runJoin (blobExists <$> blobs) of - (True, False) -> pure (deleting t1) - (False, True) -> pure (inserting t2) - _ -> diff differ t1 t2 +-- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. +diffTermPair :: Functor syntax => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Task (Diff syntax ann1 ann2) +diffTermPair _ (This t1 ) = pure (deleting t1) +diffTermPair _ (That t2) = pure (inserting t2) +diffTermPair differ (These t1 t2) = diff differ t1 t2 keepCategory :: HasField fields Category => Record fields -> Record '[Category] keepCategory = (:. Nil) . category diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 50ddc7dae..edc5593b4 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-} module Semantic.IO ( readFile +, readFilePair , isDirectory , readBlobPairsFromHandle , readBlobsFromHandle @@ -9,7 +10,6 @@ module Semantic.IO , languageForFilePath ) where -import Control.Exception (catch, IOException) import Control.Monad.IO.Class import Data.Aeson import qualified Data.Blob as Blob @@ -21,6 +21,7 @@ import Data.Source import Data.String import Data.Text import Data.These +import Data.Traversable import GHC.Generics import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -33,11 +34,21 @@ import System.Directory (doesDirectoryExist) import Text.Read -- | Read a utf8-encoded file to a 'Blob'. -readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob -readFile path@"/dev/null" _ = pure (Blob.emptyBlob path) +readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob) +readFile "/dev/null" _ = pure Nothing readFile path language = do - raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe B.ByteString)) - pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw) + raw <- liftIO $ (Just <$> B.readFile path) + pure $ Blob.sourceBlob path language . fromBytes <$> raw + +readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair +readFilePair a b = do + before <- uncurry readFile a + after <- uncurry readFile b + case (before, after) of + (Just a, Nothing) -> pure (Join (This a)) + (Nothing, Just b) -> pure (Join (That b)) + (Just a, Just b) -> pure (Join (These a b)) + _ -> fail "expected file pair with content on at least one side" isDirectory :: MonadIO m => FilePath -> m Bool isDirectory path = liftIO (doesDirectoryExist path) >>= pure @@ -47,12 +58,12 @@ languageForFilePath :: FilePath -> Maybe Language languageForFilePath = languageForType . takeExtension -- | Read JSON encoded blob pairs from a handle. -readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob] +readBlobPairsFromHandle :: MonadIO m => Handle -> m [Blob.BlobPair] readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle where + toBlobPairs :: BlobDiff -> [Blob.BlobPair] toBlobPairs BlobDiff{..} = toBlobPair <$> blobs - toBlobPair blobs = Join (fromThese empty empty (runJoin (toBlob <$> blobs))) - where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs))) + toBlobPair blobs = toBlob <$> blobs -- | Read JSON encoded blobs from a handle. readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob] @@ -60,13 +71,14 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle where toBlobs BlobParse{..} = fmap toBlob blobs readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob] -readBlobsFromPaths = traverse (uncurry Semantic.IO.readFile) +readBlobsFromPaths files = traverse (uncurry Semantic.IO.readFile) files >>= pure . catMaybes readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob] readBlobsFromDir path = do paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path) let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths - traverse (uncurry readFile) paths' + blobs <- traverse (uncurry readFile) paths' + pure (catMaybes blobs) readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a readFromHandle h = do diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 9b1b8d3d5..d101569fc 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -17,6 +17,8 @@ module Semantic.Task , distribute , distributeFor , distributeFoldMap +, bidistribute +, bidistributeFor , defaultOptions , configureOptionsForHandle , terminalFormatter @@ -41,6 +43,8 @@ import Data.Diff import qualified Data.Error as Error import Data.Foldable (fold, for_) import Data.Functor.Both as Both hiding (snd) +import Data.Bitraversable +import Data.Bifunctor import Data.Functor.Foldable (cata) import Data.Language import Data.Record @@ -61,7 +65,7 @@ import Semantic.Queue data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] - ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob] + ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [BlobPair] WriteToOutput :: Either Handle FilePath -> B.ByteString -> TaskF () WriteLog :: Level -> String -> [(String, String)] -> TaskF () WriteStat :: Stat -> TaskF () @@ -71,6 +75,7 @@ data TaskF output where Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2) Render :: Renderer input output -> input -> TaskF output Distribute :: Traversable t => t (Task output) -> TaskF (t output) + Bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> TaskF (t output1 output2) -- | For MonadIO. LiftIO :: IO a -> TaskF a @@ -93,7 +98,7 @@ readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob] readBlobs from = ReadBlobs from `Then` return -- | 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 :: Either Handle [Both (FilePath, Maybe Language)] -> Task [Both Blob] +readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [BlobPair] readBlobPairs from = ReadBlobPairs from `Then` return -- | A 'Task' which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'. @@ -134,12 +139,24 @@ render renderer input = Render renderer input `Then` return distribute :: Traversable t => t (Task output) -> Task (t output) distribute tasks = Distribute tasks `Then` return +-- | Distribute a 'Bitraversable' container of 'Task's over the available cores (i.e. execute them concurrently), collecting their results. +-- +-- This is a concurrent analogue of 'bisequenceA'. +bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> Task (t output1 output2) +bidistribute tasks = Bidistribute tasks `Then` return + -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results. -- -- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped). distributeFor :: Traversable t => t a -> (a -> Task output) -> Task (t output) distributeFor inputs toTask = distribute (fmap toTask inputs) +-- | Distribute the application of a function to each element of a 'Bitraversable' container of inputs over the available cores (i.e. perform the functions concurrently for each element), collecting the results. +-- +-- This is a concurrent analogue of 'bifor' or 'bitraverse' (with the arguments flipped). +bidistributeFor :: Bitraversable t => t a b -> (a -> Task output1) -> (b -> Task output2) -> Task (t output1 output2) +bidistributeFor inputs toTask1 toTask2 = bidistribute (bimap toTask1 toTask2 inputs) + -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value. -- -- This is a concurrent analogue of 'foldMap'. @@ -176,11 +193,11 @@ runTaskWithOptions options task = do run options logger statter = go where go :: Task a -> IO (Either SomeException a) - go = iterFreerA (\ task yield -> case task of + go = iterFreerA (\ yield task -> case task of ReadBlobs (Left handle) -> (IO.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException) ReadBlobs (Right paths@[(path, Nothing)]) -> (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException) ReadBlobs (Right paths) -> (IO.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException) - ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (traverse (uncurry IO.readFile))) source >>= yield) `catchError` (pure . Left . toException) + ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (runBothWith IO.readFilePair)) source >>= yield) `catchError` (pure . Left . toException) WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield WriteStat stat -> queue statter stat >>= yield @@ -190,6 +207,7 @@ runTaskWithOptions options task = do Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) >>= yield Render renderer input -> pure (renderer input) >>= yield Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq)) + Bidistribute tasks -> Async.runConcurrently (bitraverse (Async.Concurrently . go) (Async.Concurrently . go) tasks) >>= either (pure . Left) yield . bisequenceA . withStrategy (parBitraversable (parTraversable rseq) (parTraversable rseq)) LiftIO action -> action >>= yield Throw err -> pure (Left err) Catch during handler -> do @@ -198,6 +216,9 @@ runTaskWithOptions options task = do Left err -> go (handler err) >>= either (pure . Left) yield Right a -> yield a) . fmap Right + parBitraversable :: Bitraversable t => Strategy a -> Strategy b -> Strategy (t a b) + parBitraversable strat1 strat2 = bitraverse (rparWith strat1) (rparWith strat2) + runParser :: Options -> Blob -> Parser term -> Task term runParser Options{..} blob@Blob{..} = go where diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4675ba7bb..4b441c5cc 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -5,10 +5,11 @@ module Semantic.Util where import Analysis.Declaration import Control.Monad.IO.Class import Data.Align.Generic +import Data.Maybe import Data.Blob import Data.Diff -import Data.Functor.Both import Data.Functor.Classes +import Data.Bifunctor.Join import Data.Range import Data.Record import Data.Span @@ -21,7 +22,7 @@ import Semantic.IO as IO import Semantic.Task file :: MonadIO m => FilePath -> m Blob -file path = IO.readFile path (languageForFilePath path) +file path = IO.readFile path (languageForFilePath path) >>= pure . fromJust diffWithParser :: (HasField fields Data.Span.Span, HasField fields Range, @@ -29,12 +30,13 @@ diffWithParser :: (HasField fields Data.Span.Span, Traversable syntax, Functor syntax, Foldable syntax, Diffable syntax, GAlign syntax, HasDeclaration syntax) - => Parser (Term syntax (Record fields)) - -> Both Blob + => + Parser (Term syntax (Record fields)) + -> BlobPair -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields))) diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) where - run parse sourceBlobs = distributeFor sourceBlobs parse >>= runBothWith (diffTermPair sourceBlobs diffTerms) + run parse blobs = bidistributeFor (runJoin blobs) parse parse >>= diffTermPair diffTerms diffBlobWithParser :: (HasField fields Data.Span.Span, HasField fields Range, diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index e8aae8ed3..1d02e64b7 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -240,8 +240,8 @@ isMethodOrFunction a = case unTerm a of (a `In` _) | getField a == C.SingletonMethod -> True _ -> False -blobsForPaths :: Both FilePath -> IO (Both Blob) -blobsForPaths = traverse (readFile . ("test/fixtures/toc/" <>)) +blobsForPaths :: Both FilePath -> IO BlobPair +blobsForPaths = readFilePair . fmap ("test/fixtures/toc/" <>) sourceSpanBetween :: (Int, Int) -> (Int, Int) -> Span sourceSpanBetween (s1, e1) (s2, e2) = Span (Pos s1 e1) (Pos s2 e2) @@ -253,4 +253,4 @@ blankDiff = merge (arrayInfo, arrayInfo) (Indexed [ inserting (Term $ literalInf literalInfo = Nothing :. Range 1 2 :. StringLiteral :. sourceSpanBetween (1, 2) (1, 4) :. Nil blankDiffBlobs :: Both Blob -blankDiffBlobs = both (Blob (fromText "[]") nullOid "a.js" (Just defaultPlainBlob) (Just TypeScript)) (Blob (fromText "[a]") nullOid "b.js" (Just defaultPlainBlob) (Just TypeScript)) +blankDiffBlobs = both (Blob (fromText "[]") "a.js" (Just TypeScript)) (Blob (fromText "[a]") "b.js" (Just TypeScript)) diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 2bbe089d0..671f5a63d 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -38,7 +38,6 @@ parseFixtures = , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput) - , (SomeRenderer JSONTermRenderer, Right [("not-a-file.rb", Just Ruby)], emptyJsonParseTreeOutput) , (SomeRenderer ToCTermRenderer, Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tocOutput) ] where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)] @@ -59,6 +58,6 @@ diffFixtures = ] where pathMode = Right [both ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)] - jsonOutput = "{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"oids\":[\"0000000000000000000000000000000000000000\",\"0000000000000000000000000000000000000000\"],\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n" + jsonOutput = "{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"paths\":[\"test/fixtures/ruby/method-declaration.A.rb\",\"test/fixtures/ruby/method-declaration.B.rb\"]}\n" sExpressionOutput = "(Program\n (Method\n (Empty)\n { (Identifier)\n ->(Identifier) }\n {+(Identifier)+}\n (\n {+(Identifier)+})))\n" tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index e9ee6982b..6c04703bb 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -9,53 +9,52 @@ import Prelude hiding (readFile) import Semantic.IO import System.Exit (ExitCode(..)) import System.IO (IOMode(..), openFile) -import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall) +import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall, anyIOException) import Test.Hspec.Expectations.Pretty spec :: Spec spec = parallel $ do describe "readFile" $ do it "returns a blob for extant files" $ do - blob <- readFile "semantic-diff.cabal" Nothing + Just blob <- readFile "semantic-diff.cabal" Nothing blobPath blob `shouldBe` "semantic-diff.cabal" - it "returns a nullBlob for absent files" $ do - blob <- readFile "this file should not exist" Nothing - nullBlob blob `shouldBe` True + it "throws for absent files" $ do + readFile "this file should not exist" Nothing `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do let a = sourceBlob "method.rb" (Just Ruby) "def foo; end" let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff.json" - blobs `shouldBe` [both a b] + blobs `shouldBe` [blobPairDiffing a b] it "returns blobs when there's no before" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff-no-before.json" - blobs `shouldBe` [both (emptyBlob "method.rb") b] + blobs `shouldBe` [blobPairInserting b] it "returns blobs when there's null before" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff-null-before.json" - blobs `shouldBe` [both (emptyBlob "method.rb") b] + blobs `shouldBe` [blobPairInserting b] it "returns blobs when there's no after" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff-no-after.json" - blobs `shouldBe` [both a (emptyBlob "method.rb")] + blobs `shouldBe` [blobPairDeleting a] it "returns blobs when there's null after" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff-null-after.json" - blobs `shouldBe` [both a (emptyBlob "method.rb")] + blobs `shouldBe` [blobPairDeleting a] it "returns blobs for unsupported language" $ do h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode blobs <- readBlobPairsFromHandle h let b' = sourceBlob "test.kt" Nothing "fun main(args: Array) {\nprintln(\"hi\")\n}\n" - blobs `shouldBe` [both (emptyBlob "test.kt") b'] + blobs `shouldBe` [blobPairInserting b'] it "detects language based on filepath for empty language" $ do blobs <- blobsFromFilePath "test/fixtures/input/diff-empty-language.json" - blobs `shouldBe` [both a b] + blobs `shouldBe` [blobPairDiffing a b] it "throws on blank input" $ do h <- openFile "test/fixtures/input/blank.json" ReadMode @@ -65,6 +64,10 @@ spec = parallel $ do h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode readBlobsFromHandle h `shouldThrow` (== ExitFailure 1) + it "throws if null on before and after" $ do + h <- openFile "test/fixtures/input/diff-null-both-sides.json" ReadMode + readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1) + describe "readBlobsFromHandle" $ do it "returns blobs for valid JSON encoded parse input" $ do h <- openFile "test/fixtures/input/parse.json" ReadMode diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 884b55f60..56d327478 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -28,13 +28,13 @@ spec = parallel $ do output `shouldBe` "(Program\n (Method\n (Empty)\n (Identifier)\n ([])))\n" describe "diffTermPair" $ do - it "produces an Insert when the first blob is missing" $ do - result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) replacing (termIn () []) (termIn () [])) - result `shouldBe` Diff (Patch (Insert (In () []))) + it "produces an Insert when the first term is missing" $ do + result <- runTask (diffTermPair replacing (That (termIn () []))) + result `shouldBe` (Diff (Patch (Insert (In () []))) :: Diff [] () ()) - it "produces a Delete when the second blob is missing" $ do - result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) replacing (termIn () []) (termIn () [])) - result `shouldBe` Diff (Patch (Delete (In () []))) + it "produces a Delete when the second term is missing" $ do + result <- runTask (diffTermPair replacing (This (termIn () []))) + result `shouldBe` (Diff (Patch (Delete (In () []))) :: Diff [] () ()) where - methodsBlob = Blob "def foo\nend\n" "ff7bbbe9495f61d9e1e58c597502d152bab1761e" "methods.rb" (Just defaultPlainBlob) (Just Ruby) + methodsBlob = Blob "def foo\nend\n" "methods.rb" (Just Ruby) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 90d0abd90..82ea1d181 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -2,44 +2,36 @@ module SpecHelpers ( diffFilePaths , parseFilePath -, readFile +, readFilePair , languageForFilePath ) where +import Control.Monad ((<=<)) import Control.Exception import Data.Blob import qualified Data.ByteString as B import Data.Functor.Both import Data.Language -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust) import Data.Source -import Prelude hiding (readFile) import Rendering.Renderer import Semantic import Semantic.Task +import qualified Semantic.IO as IO import System.FilePath -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO B.ByteString -diffFilePaths paths = do - blobs <- traverse readFile paths - runTask (diffBlobPair SExpressionDiffRenderer blobs) +diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionDiffRenderer -- | Returns an s-expression parse tree for the specified FilePath. parseFilePath :: FilePath -> IO B.ByteString -parseFilePath path = do - blob <- readFile path - runTask (parseBlob SExpressionTermRenderer blob) +parseFilePath path = IO.readFile path (languageForFilePath path) >>= pure . fromJust >>= runTask . parseBlob SExpressionTermRenderer --- | Read a file to a Blob. --- --- NB: This is intentionally duplicated from Command.Files because eventually --- we want to be able to test a core Semantic library that has no knowledge of --- the filesystem or Git. The tests, however, will still leverage reading files. -readFile :: FilePath -> IO Blob -readFile path = do - source <- (Just . fromBytes <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe Source)) - pure $ fromMaybe (emptyBlob path) (sourceBlob path (languageForFilePath path) <$> source) +-- | Read two files to a BlobPair. +readFilePair :: Both FilePath -> IO BlobPair +readFilePair paths = let paths' = fmap (\p -> (p, languageForFilePath p)) paths in + runBothWith IO.readFilePair paths' -- | Returns a Maybe Language based on the FilePath's extension. languageForFilePath :: FilePath -> Maybe Language diff --git a/test/fixtures/input/diff-null-both-sides.json b/test/fixtures/input/diff-null-both-sides.json new file mode 100644 index 000000000..4de8c1966 --- /dev/null +++ b/test/fixtures/input/diff-null-both-sides.json @@ -0,0 +1,6 @@ +{ + "blobs": [{ + "before": null, + "after": null + }] +} diff --git a/vendor/freer-cofreer b/vendor/freer-cofreer index f18b72357..22164cdeb 160000 --- a/vendor/freer-cofreer +++ b/vendor/freer-cofreer @@ -1 +1 @@ -Subproject commit f18b723579f700674dda90ed1519f6e7298e2117 +Subproject commit 22164cdebd939dc9b4a21b41a5e4968f991435d1