@@ -15,6 +15,7 @@ import Control.Concurrent.Extra (withNumCapabilities)
1515import Control.Concurrent.MVar (MVar , newEmptyMVar ,
1616 putMVar , tryReadMVar )
1717import Control.Concurrent.STM.Stats (dumpSTMStats )
18+ import Control.Exception.Safe as Safe
1819import Control.Monad.Extra (concatMapM , unless ,
1920 when )
2021import Control.Monad.IO.Class (liftIO )
@@ -114,16 +115,17 @@ import qualified Language.LSP.Server as LSP
114115import Numeric.Natural (Natural )
115116import Options.Applicative hiding (action )
116117import qualified System.Directory.Extra as IO
117- import System.Exit (ExitCode (ExitFailure ),
118+ import System.Exit (ExitCode (ExitFailure , ExitSuccess ),
118119 exitWith )
119120import System.FilePath (takeExtension ,
120- takeFileName )
121+ takeFileName , (</>) )
121122import System.IO (BufferMode (LineBuffering , NoBuffering ),
122123 Handle , hFlush ,
123124 hPutStrLn ,
124125 hSetBuffering ,
125126 hSetEncoding , stderr ,
126127 stdin , stdout , utf8 )
128+ import System.Process (readProcessWithExitCode )
127129import System.Random (newStdGen )
128130import System.Time.Extra (Seconds , offsetTime ,
129131 showDuration )
@@ -141,6 +143,7 @@ data Log
141143 | LogSession Session. Log
142144 | LogPluginHLS PluginHLS. Log
143145 | LogRules Rules. Log
146+ | LogUsingGit
144147 deriving Show
145148
146149instance Pretty Log where
@@ -164,6 +167,7 @@ instance Pretty Log where
164167 LogSession msg -> pretty msg
165168 LogPluginHLS msg -> pretty msg
166169 LogRules msg -> pretty msg
170+ LogUsingGit -> " Using git to list file, relying on .gitignore"
167171
168172data Command
169173 = Check [FilePath ] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures
@@ -383,7 +387,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
383387 putStrLn " Report bugs at https://github.com/haskell/haskell-language-server/issues"
384388
385389 putStrLn $ " \n Step 1/4: Finding files to test in " ++ dir
386- files <- expandFiles (argFiles ++ [" ." | null argFiles])
390+ files <- expandFiles recorder (argFiles ++ [" ." | null argFiles])
387391 -- LSP works with absolute file paths, so try and behave similarly
388392 absoluteFiles <- nubOrd <$> mapM IO. canonicalizePath files
389393 putStrLn $ " Found " ++ show (length absoluteFiles) ++ " files"
@@ -445,16 +449,45 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
445449 registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing )
446450 c ide
447451
448- expandFiles :: [FilePath ] -> IO [FilePath ]
449- expandFiles = concatMapM $ \ x -> do
452+ -- | List the haskell files given some paths
453+ --
454+ -- It will rely on git if possible to filter-out ignored files.
455+ expandFiles :: Recorder (WithPriority Log ) -> [FilePath ] -> IO [FilePath ]
456+ expandFiles recorder paths = do
457+ let haskellFind x =
458+ let recurse " ." = True
459+ recurse y | " ." `isPrefixOf` takeFileName y = False -- skip .git etc
460+ recurse y = takeFileName y `notElem` [" dist" , " dist-newstyle" ] -- cabal directories
461+ in filter (\ y -> takeExtension y `elem` [" .hs" , " .lhs" ]) <$> IO. listFilesInside (return . recurse) x
462+ git args = do
463+ mResult <- (Just <$> readProcessWithExitCode " git" args " " ) `Safe.catchAny` const (pure Nothing )
464+ pure $
465+ case mResult of
466+ Just (ExitSuccess , gitStdout, _) -> Just gitStdout
467+ _ -> Nothing
468+ mHasGit <- git [" status" ]
469+ when (isJust mHasGit) $ logWith recorder Info LogUsingGit
470+ let findFiles =
471+ case mHasGit of
472+ Just _ -> \ path -> do
473+ let lookups =
474+ if takeExtension path `elem` [" .hs" , " .lhs" ]
475+ then [path]
476+ else [path </> " *.hs" , path </> " *.lhs" ]
477+ gitLines args = fmap lines <$> git args
478+ mTracked <- gitLines (" ls-files" : lookups)
479+ mUntracked <- gitLines (" ls-files" : " -o" : lookups)
480+ case mTracked <> mUntracked of
481+ Nothing -> haskellFind path
482+ Just files -> pure files
483+ _ -> haskellFind
484+
485+ flip concatMapM paths $ \ x -> do
450486 b <- IO. doesFileExist x
451487 if b
452488 then return [x]
453489 else do
454- let recurse " ." = True
455- recurse y | " ." `isPrefixOf` takeFileName y = False -- skip .git etc
456- recurse y = takeFileName y `notElem` [" dist" , " dist-newstyle" ] -- cabal directories
457- files <- filter (\ y -> takeExtension y `elem` [" .hs" , " .lhs" ]) <$> IO. listFilesInside (return . recurse) x
490+ files <- findFiles x
458491 when (null files) $
459492 fail $ " Couldn't find any .hs/.lhs files inside directory: " ++ x
460493 return files
0 commit comments