Skip to content
This repository was archived by the owner on Apr 1, 2025. It is now read-only.

Commit ff9e140

Browse files
robrixrobrix
authored
Merge pull request #212 from github/from-paths
New options for readBlobsFromGitRepo
2 parents 8f15669 + 3409779 commit ff9e140

File tree

4 files changed

+55
-13
lines changed

4 files changed

+55
-13
lines changed

‎src/Data/Blob/IO.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,8 +39,8 @@ readBlobsFromDir path = liftIO . fmap catMaybes $
3939
findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath)
4040

4141
-- | Read all blobs from the Git repo with Language.supportedExts
42-
readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> m [Blob]
43-
readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $
42+
readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> [FilePath] -> m [Blob]
43+
readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybes $
4444
Git.lsTree path oid >>= Async.mapConcurrently (blobFromTreeEntry path)
4545
where
4646
-- 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 $
5050
, lang `elem` codeNavLanguages
5151
, not (pathIsMinified path)
5252
, path `notElem` excludePaths
53+
, null includePaths || path `elem` includePaths
5354
= Just . sourceBlob' path lang oid . fromText <$> Git.catFile gitDir oid
5455
blobFromTreeEntry _ _ = pure Nothing
5556

‎src/Semantic/CLI.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,9 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
114114
<$> option str (long "gitDir" <> help "A .git directory to read from")
115115
<*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
116116
<*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
117-
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin"))
117+
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
118+
<|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
119+
<|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
118120
<|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
119121
<|> pure (FilesFromHandle stdin)
120122
pure $ Task.readBlobs filesOrStdin >>= renderer
@@ -131,7 +133,9 @@ tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Gene
131133
<$> option str (long "gitDir" <> help "A .git directory to read from")
132134
<*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
133135
<*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
134-
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin"))
136+
<|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
137+
<|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
138+
<|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
135139
<|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
136140
<|> pure (FilesFromHandle stdin)
137141
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format

‎src/Semantic/Task/Files.hs‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ module Semantic.Task.Files
1414
, Handle (..)
1515
, FilesC(..)
1616
, FilesArg(..)
17-
, Excludes(..)
17+
, PathFilter(..)
1818
) where
1919

2020
import Control.Effect.Carrier
@@ -36,15 +36,17 @@ data Source blob where
3636
FromPath :: File -> Source Blob
3737
FromHandle :: Handle 'IO.ReadMode -> Source [Blob]
3838
FromDir :: FilePath -> Source [Blob]
39-
FromGitRepo :: FilePath -> Git.OID -> Excludes -> Source [Blob]
39+
FromGitRepo :: FilePath -> Git.OID -> PathFilter -> Source [Blob]
4040
FromPathPair :: Both File -> Source BlobPair
4141
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
4242

4343
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
4444

45-
data Excludes
45+
data PathFilter
4646
= ExcludePaths [FilePath]
4747
| ExcludeFromHandle (Handle 'IO.ReadMode)
48+
| IncludePaths [FilePath]
49+
| IncludePathsFromHandle (Handle 'IO.ReadMode)
4850

4951
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
5052
data Files (m :: * -> *) k
@@ -80,8 +82,10 @@ instance (Member (Error SomeException) sig, Member Catch sig, MonadIO m, Carrier
8082
Read (FromPath path) k -> rethrowing (readBlobFromFile' path) >>= k
8183
Read (FromHandle handle) k -> rethrowing (readBlobsFromHandle handle) >>= k
8284
Read (FromDir dir) k -> rethrowing (readBlobsFromDir dir) >>= k
83-
Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths) >>= k
84-
Read (FromGitRepo path sha (ExcludeFromHandle handle)) k -> rethrowing (readPathsFromHandle handle >>= readBlobsFromGitRepo path sha) >>= k
85+
Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths mempty) >>= k
86+
Read (FromGitRepo path sha (ExcludeFromHandle handle)) k -> rethrowing (readPathsFromHandle handle >>= (\x -> readBlobsFromGitRepo path sha x mempty)) >>= k
87+
Read (FromGitRepo path sha (IncludePaths includePaths)) k -> rethrowing (readBlobsFromGitRepo path sha mempty includePaths) >>= k
88+
Read (FromGitRepo path sha (IncludePathsFromHandle h)) k -> rethrowing (readPathsFromHandle h >>= readBlobsFromGitRepo path sha mempty) >>= k
8589
Read (FromPathPair paths) k -> rethrowing (runBothWith readFilePair paths) >>= k
8690
Read (FromPairHandle handle) k -> rethrowing (readBlobPairsFromHandle handle) >>= k
8791
ReadProject rootDir dir language excludeDirs k -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k
@@ -96,7 +100,7 @@ readBlob file = send (Read (FromPath file) pure)
96100
data FilesArg
97101
= FilesFromHandle (Handle 'IO.ReadMode)
98102
| FilesFromPaths [File]
99-
| FilesFromGitRepo FilePath Git.OID Excludes
103+
| FilesFromGitRepo FilePath Git.OID PathFilter
100104

101105
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
102106
readBlobs :: (Member Files sig, Carrier sig m, MonadIO m) => FilesArg -> m [Blob]
@@ -107,7 +111,7 @@ readBlobs (FilesFromPaths [path]) = do
107111
then send (Read (FromDir (filePath path)) pure)
108112
else pure <$> send (Read (FromPath path) pure)
109113
readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
110-
readBlobs (FilesFromGitRepo path sha excludes) = send (Read (FromGitRepo path sha excludes) pure)
114+
readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure)
111115

112116
-- | 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.
113117
readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]

‎test/Semantic/IO/Spec.hs‎

Lines changed: 35 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -31,12 +31,46 @@ spec = do
3131
git ["config", "user.email", "'test@test.test'"]
3232
git ["commit", "-am", "'test commit'"]
3333

34-
readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") []
34+
readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") [] []
3535
let files = sortOn fileLanguage (blobFile <$> blobs)
3636
files `shouldBe` [ File "foo.py" Python
3737
, File "bar.rb" Ruby
3838
]
3939

40+
when hasGit . it "should read from a git directory with --only" $ do
41+
-- This temporary directory will be cleaned after use.
42+
blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
43+
shelly $ silently $ do
44+
cd (fromString dir)
45+
let git = run_ "git"
46+
git ["init"]
47+
run_ "touch" ["foo.py", "bar.rb"]
48+
git ["add", "foo.py", "bar.rb"]
49+
git ["config", "user.name", "'Test'"]
50+
git ["config", "user.email", "'test@test.test'"]
51+
git ["commit", "-am", "'test commit'"]
52+
53+
readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") [] ["foo.py"]
54+
let files = sortOn fileLanguage (blobFile <$> blobs)
55+
files `shouldBe` [ File "foo.py" Python ]
56+
57+
when hasGit . it "should read from a git directory with --exclude" $ do
58+
-- This temporary directory will be cleaned after use.
59+
blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
60+
shelly $ silently $ do
61+
cd (fromString dir)
62+
let git = run_ "git"
63+
git ["init"]
64+
run_ "touch" ["foo.py", "bar.rb"]
65+
git ["add", "foo.py", "bar.rb"]
66+
git ["config", "user.name", "'Test'"]
67+
git ["config", "user.email", "'test@test.test'"]
68+
git ["commit", "-am", "'test commit'"]
69+
70+
readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") ["foo.py"] []
71+
let files = sortOn fileLanguage (blobFile <$> blobs)
72+
files `shouldBe` [ File "bar.rb" Ruby ]
73+
4074
describe "readFile" $ do
4175
it "returns a blob for extant files" $ do
4276
Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
@@ -109,4 +143,3 @@ spec = do
109143

110144
jsonException :: Selector InvalidJSONException
111145
jsonException = const True
112-

0 commit comments

Comments
 (0)