diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 3465e463ea..75b041b597 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -39,8 +39,8 @@ readBlobsFromDir path = liftIO . fmap catMaybes $ findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath) -- | Read all blobs from the Git repo with Language.supportedExts -readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> m [Blob] -readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $ +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. @@ -50,6 +50,7 @@ readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $ , lang `elem` codeNavLanguages , not (pathIsMinified path) , path `notElem` excludePaths + , null includePaths || path `elem` includePaths = Just . sourceBlob' path lang oid . fromText <$> Git.catFile gitDir oid blobFromTreeEntry _ _ = pure Nothing diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 9866426056..4e47f0da2b 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -114,7 +114,9 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa <$> 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")) + <|> 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...")) <|> pure (FilesFromHandle stdin) pure $ Task.readBlobs filesOrStdin >>= renderer @@ -131,7 +133,9 @@ tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Gene <$> 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")) + <|> 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...")) <|> pure (FilesFromHandle stdin) pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index dc2366e915..41f59395e9 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -14,7 +14,7 @@ module Semantic.Task.Files , Handle (..) , FilesC(..) , FilesArg(..) - , Excludes(..) + , PathFilter(..) ) where import Control.Effect.Carrier @@ -36,15 +36,17 @@ data Source blob where FromPath :: File -> Source Blob FromHandle :: Handle 'IO.ReadMode -> Source [Blob] FromDir :: FilePath -> Source [Blob] - FromGitRepo :: FilePath -> Git.OID -> Excludes -> Source [Blob] + FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob] FromPathPair :: Both File -> Source BlobPair FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode) -data Excludes +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 @@ -80,8 +82,10 @@ 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) >>= k - Read (FromGitRepo path sha (ExcludeFromHandle handle)) k -> rethrowing (readPathsFromHandle handle >>= readBlobsFromGitRepo path sha) >>= 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 (FromPairHandle handle) k -> rethrowing (readBlobPairsFromHandle handle) >>= k ReadProject rootDir dir language excludeDirs k -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k @@ -96,7 +100,7 @@ readBlob file = send (Read (FromPath file) pure) data FilesArg = FilesFromHandle (Handle 'IO.ReadMode) | FilesFromPaths [File] - | FilesFromGitRepo FilePath Git.OID Excludes + | 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] @@ -107,7 +111,7 @@ readBlobs (FilesFromPaths [path]) = do then send (Read (FromDir (filePath path)) pure) else pure <$> send (Read (FromPath path) pure) readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths -readBlobs (FilesFromGitRepo path sha excludes) = send (Read (FromGitRepo path sha excludes) pure) +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] diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 80bea9b96b..de5610729b 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -31,12 +31,46 @@ spec = do git ["config", "user.email", "'test@test.test'"] git ["commit", "-am", "'test commit'"] - readBlobsFromGitRepo (dir ".git") (Git.OID "HEAD") [] + readBlobsFromGitRepo (dir ".git") (Git.OID "HEAD") [] [] let files = sortOn fileLanguage (blobFile <$> blobs) files `shouldBe` [ File "foo.py" Python , File "bar.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 + shelly $ silently $ do + cd (fromString dir) + let git = run_ "git" + git ["init"] + run_ "touch" ["foo.py", "bar.rb"] + git ["add", "foo.py", "bar.rb"] + git ["config", "user.name", "'Test'"] + git ["config", "user.email", "'test@test.test'"] + git ["commit", "-am", "'test commit'"] + + readBlobsFromGitRepo (dir ".git") (Git.OID "HEAD") [] ["foo.py"] + let files = sortOn fileLanguage (blobFile <$> blobs) + files `shouldBe` [ File "foo.py" Python ] + + 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 + shelly $ silently $ do + cd (fromString dir) + let git = run_ "git" + git ["init"] + run_ "touch" ["foo.py", "bar.rb"] + git ["add", "foo.py", "bar.rb"] + git ["config", "user.name", "'Test'"] + git ["config", "user.email", "'test@test.test'"] + git ["commit", "-am", "'test commit'"] + + readBlobsFromGitRepo (dir ".git") (Git.OID "HEAD") ["foo.py"] [] + let files = sortOn fileLanguage (blobFile <$> blobs) + files `shouldBe` [ File "bar.rb" Ruby ] + describe "readFile" $ do it "returns a blob for extant files" $ do Just blob <- readBlobFromFile (File "semantic.cabal" Unknown) @@ -109,4 +143,3 @@ spec = do jsonException :: Selector InvalidJSONException jsonException = const True -