Merge pull request #212 from github/from-paths

New options for readBlobsFromGitRepo

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
 

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

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]

test/Semantic/IO/Spec.hs

@@ -31,12 +31,46 @@ spec = do
           git ["config", "user.email", "'[email protected]'"]
           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", "'[email protected]'"]
+          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", "'[email protected]'"]
+          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
-