github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 01:42:43 +03:00
Code Issues Projects Releases Wiki Activity

Add readProjectEntry to the Files effects

Browse Source
This commit is contained in:
joshvera 2018-04-24 15:48:44 -04:00
parent 3fb3097c96
commit 421cc0d1a1
7 changed files with 23 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/Semantic/IO.hs
View File

@ -11,6 +11,7 @@ module Semantic.IO
, NoLanguageForBlob(..)
, readBlob
, readProject
, readProjectEntry
, readBlobs
, readBlobPairs
, writeToOutput
@ -94,6 +95,15 @@ readProjectFromPaths rootDir lang = do
toFile path = File path (Just lang)
exts = extensionsForLanguage lang
readProjectEntryFromPath :: MonadIO m => FilePath -> Language -> m Project
readProjectEntryFromPath path lang = do
paths <- liftIO $ filter (/= path) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir)
pure $ Project rootDir (toFile <$> (path : paths)) lang
where
rootDir = takeDirectory path
toFile path = File path (Just lang)
exts = extensionsForLanguage lang
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
readBlobsFromDir path = do
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
@ -159,6 +169,9 @@ readBlobPairs = send . ReadBlobPairs
readProject :: Member Files effs => FilePath -> Language -> Eff effs Project
readProject dir = send . ReadProject dir
readProjectEntry :: Member Files effs => FilePath -> Language -> Eff effs Project
readProjectEntry file = send . ReadProjectEntry file
-- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
writeToOutput path = send . WriteToOutput path
@ -170,6 +183,7 @@ data Files out where
ReadBlobs :: Either Handle [File] -> Files [Blob.Blob]
ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
ReadProject :: FilePath -> Language -> Files Project
ReadProjectEntry :: FilePath -> Language -> Files Project
WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
-- | Run a 'Files' effect in 'IO'.
@ -181,6 +195,7 @@ runFiles = interpret $ \ files -> case files of
ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
ReadProject dir language -> rethrowing (readProjectFromPaths dir language)
ReadProjectEntry file language -> rethrowing (readProjectEntryFromPath file language)
WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)

4
src/Semantic/Util.hs
View File

@ -50,13 +50,15 @@ evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject g
evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby)
pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
-- Evaluate a project, starting at a single entrypoint.
evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject path lang >>= parsePackage parser prelude)
evaluateProjectEntry parser lang prelude path = evaluatePackage <$> runTask (readProjectEntry path lang >>= parsePackage parser prelude)
parseFile :: Parser term -> FilePath -> IO term
parseFile parser = runTask . (parse parser <=< readBlob . file)

2
test/Analysis/Go/Spec.hs
View File

@ -32,4 +32,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/go/analysis/"
evaluate entry = evalGoProject (fixtures <> entry)
evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProjectEntry goParser Language.Go Nothing path

2
test/Analysis/PHP/Spec.hs
View File

@ -36,4 +36,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/php/analysis/"
evaluate entry = evalPHPProject (fixtures <> entry)
evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProjectEntry phpParser Language.PHP Nothing path

2
test/Analysis/Python/Spec.hs
View File

@ -51,4 +51,4 @@ spec = parallel $ do
addr = Address . Precise
fixtures = "test/fixtures/python/analysis/"
evaluate entry = evalPythonProject (fixtures <> entry)
evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProjectEntry pythonParser Language.Python pythonPrelude path

2
test/Analysis/Ruby/Spec.hs
View File

@ -64,4 +64,4 @@ spec = parallel $ do
addr = Address . Precise
fixtures = "test/fixtures/ruby/analysis/"
evaluate entry = evalRubyProject (fixtures <> entry)
evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProjectEntry rubyParser Language.Ruby rubyPrelude path

2
test/Analysis/TypeScript/Spec.hs
View File

@ -43,4 +43,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = evalTypeScriptProject (fixtures <> entry)
evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProjectEntry typescriptParser Language.TypeScript Nothing path