Add ability to exclude directories from globbing

semantic.cabal

@@ -167,6 +167,7 @@ library
                      , cmark-gfm
                      , containers
                      , directory
+                     , directory-tree
                      , effects
                      , filepath
                      , free

src/Data/Language.hs

@@ -36,10 +36,10 @@ languageForType mediaType = case mediaType of
 extensionsForLanguage :: Maybe Language -> [String]
 extensionsForLanguage Nothing         = []
 extensionsForLanguage (Just language) = case language of
-  Go -> ["go"]
-  JavaScript -> ["js"]
-  PHP -> ["php"]
-  Python -> ["py"]
-  Ruby -> ["rb"]
-  TypeScript -> ["ts", "tsx", "d.tsx"]
+  Go -> [".go"]
+  JavaScript -> [".js"]
+  PHP -> [".php"]
+  Python -> [".py"]
+  Ruby -> [".rb"]
+  TypeScript -> [".ts", ".tsx", ".d.tsx"]
   _ -> []

src/Semantic/CLI.hs

@@ -35,8 +35,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
 runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
 runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
-runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString
-runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir
+runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> [FilePath] -> Task.TaskEff ByteString
+runGraph (SomeRenderer r) dir excludeDirs = Semantic.graph r <=< Task.readProject dir excludeDirs
 
 -- | A parser for the application's command-line arguments.
 --
@@ -90,8 +90,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
       renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
               <|> flag'                                (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
       rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY"))
+      excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
       entryPoints <- NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)"))
-      pure $ runGraph renderer rootDir entryPoints
+      pure $ runGraph renderer rootDir entryPoints excludeDirs
 
     filePathReader = eitherReader parseFilePath
     parseFilePath arg = case splitWhen (== ':') arg of

src/Semantic/IO.hs

@@ -7,6 +7,7 @@ module Semantic.IO
 , readBlobsFromHandle
 , readBlobsFromPaths
 , readBlobsFromDir
+, findFiles
 , languageForFilePath
 , NoLanguageForBlob(..)
 , readBlob
@@ -36,6 +37,8 @@ import qualified Data.List.NonEmpty as NonEmpty
 import           Prelude hiding (readFile)
 import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
+import qualified System.Directory.Tree as Tree
+import           System.Directory.Tree (AnchoredDirTree(..))
 import           System.Exit
 import           System.FilePath
 import           System.FilePath.Glob
@@ -87,9 +90,9 @@ readBlobFromPath file = do
 readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob]
 readBlobsFromPaths files = catMaybes <$> traverse readFile files
 
-readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> m Project
-readProjectFromPaths root files = do
-  paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "[^vendor]**/*." <$> exts) rootDir)
+readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> [FilePath] -> m Project
+readProjectFromPaths root files excludeDirs = do
+  paths <- liftIO $ filter (/= entryPointPath) <$> findFiles rootDir exts excludeDirs
   pure $ Project files rootDir (toFile <$> paths)
   where
     toFile path = File path (languageForFilePath path)
@@ -98,6 +101,30 @@ readProjectFromPaths root files = do
     entryPointPath = filePath entryPoint
     rootDir = fromMaybe (takeDirectory entryPointPath) root
 
+-- Recursively find files in a directory.
+findFiles :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
+findFiles path exts excludeDirs = do
+  _:/dir <- liftIO $ Tree.build path
+  pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir
+  where
+    -- Build a list of only FilePath's (remove directories and failures)
+    onlyFiles (Tree.Dir _ fs)   = concatMap onlyFiles fs
+    onlyFiles (Tree.Failed _ _) = []
+    onlyFiles (Tree.File _ f)   = [f]
+
+    -- Predicate for Files with one of the extensions in 'exts'.
+    withExtensions exts (Tree.File n _)
+      | takeExtension n `elem` exts = True
+      | otherwise                   = False
+    withExtensions _ _              = True
+
+    -- Predicate for contents NOT in a directory
+    notIn dirs (Tree.Dir n _)
+      | (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'.
+      | n `elem` dirs = False
+      | otherwise = True
+    notIn _ _ = True
+
 readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
 readBlobsFromDir path = do
   paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
@@ -160,8 +187,8 @@ readBlobs = send . ReadBlobs
 readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
 readBlobPairs = send . ReadBlobPairs
 
-readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project
-readProject dir files = send (ReadProject dir files)
+readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> [FilePath] -> Eff effs Project
+readProject dir files excludeDirs = send (ReadProject dir files excludeDirs)
 
 -- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
 writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
@@ -173,7 +200,7 @@ data Files out where
   ReadBlob      :: File -> Files Blob.Blob
   ReadBlobs     :: Either Handle [File] -> Files [Blob.Blob]
   ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
-  ReadProject   :: Maybe FilePath -> NonEmpty File -> Files Project
+  ReadProject   :: Maybe FilePath -> NonEmpty File -> [FilePath] -> Files Project
   WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
 
 -- | Run a 'Files' effect in 'IO'.
@@ -184,7 +211,7 @@ runFiles = interpret $ \ files -> case files of
   ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
   ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
   ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
-  ReadProject dir files -> rethrowing (readProjectFromPaths dir files)
+  ReadProject dir files excludeDirs -> rethrowing (readProjectFromPaths dir files excludeDirs)
   WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
 
 

src/Semantic/Util.hs

@@ -56,8 +56,7 @@ rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby
 pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
 
 -- Evaluate a project, starting at a single entrypoint.
-evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude)
-
+evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) [] >>= parsePackage parser prelude)
 
 -- Read and parse a file.
 parseFile :: Parser term -> FilePath -> IO term