Load all possible haskell source files

app/MainHie.hs

@@ -6,9 +6,11 @@ import qualified Control.Exception                     as E
 import           Control.Monad
 import           Data.Monoid                           ((<>))
 import           Data.Version                          (showVersion)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
 import qualified Data.Yaml as Yaml
 import           HIE.Bios.Types
-import           Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
+import           Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay, getProjectGhcLibDir)
 import           Haskell.Ide.Engine.MonadFunctions
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.Options
@@ -20,11 +22,15 @@ import           Options.Applicative.Simple
 import qualified Paths_haskell_ide_engine              as Meta
 import           System.Directory
 import           System.Environment
-import           System.FilePath ((</>))
+import           System.FilePath
 import           System.Info
 import           System.IO
 import qualified System.Log.Logger                     as L
 
+-- ---------------------------------------------------------------------
+
+import           RunTest
+
 -- ---------------------------------------------------------------------
 -- plugins
 
@@ -117,6 +123,8 @@ run opts = do
   progName <- getProgName
   args <- getArgs
 
+  let plugins' = plugins (optExamplePlugin opts)
+
   if optLsp opts
     then do
       -- Start up in LSP mode
@@ -136,8 +144,6 @@ run opts = do
       when (optExamplePlugin opts) $
         logm "Enabling Example2 plugin, will insert constant diagnostics etc."
 
-      let plugins' = plugins (optExamplePlugin opts)
-
       -- launch the dispatcher.
       scheduler <- newScheduler plugins' initOpts
       server scheduler origDir plugins' (optCaptureFile opts)
@@ -155,7 +161,35 @@ run opts = do
       ecradle <- getCradleInfo origDir
       case ecradle of
         Left e       -> cliOut $ "Could not get cradle:" ++ show e
-        Right cradle -> cliOut $ "Cradle:" ++ cradleDisplay cradle
+        Right cradle -> do
+          projGhc <- getProjectGhcVersion cradle
+          mlibdir <- getProjectGhcLibDir cradle
+          cliOut "\n\n###################################################\n"
+          cliOut $ "Cradle: " ++ cradleDisplay cradle
+          cliOut $ "Project Ghc version: " ++ projGhc
+          cliOut $ "Libdir: " ++ show mlibdir
+          cliOut "Searching for Haskell source files..."
+          targets <- case optFiles opts of
+            [] -> findAllSourceFiles origDir
+            xs -> concat <$> mapM findAllSourceFiles xs
+
+          cliOut $ "Found " ++ show (length targets) ++ " Haskell source files.\n"
+          cliOut "###################################################"
+          cliOut "\nFound the following files:\n"
+          mapM_ cliOut targets
+          cliOut ""
+
+          unless (optDryRun opts) $ do
+            cliOut "\nLoad them all now. This may take a very long time.\n"
+            loadDiagnostics <- runServer mlibdir plugins' targets
+
+            cliOut ""
+            cliOut "###################################################"
+            cliOut "###################################################"
+            cliOut "\nDumping diagnostics:\n\n"
+            mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics
+            cliOut "\n\nNote: loading of 'Setup.hs' is not supported."
+
 
 -- ---------------------------------------------------------------------
 
@@ -170,4 +204,7 @@ getCradleInfo currentDir = do
 cliOut :: String -> IO ()
 cliOut = putStrLn
 
+cliOut' :: T.Text -> IO ()
+cliOut' = T.putStrLn
+
 -- ---------------------------------------------------------------------

app/RunTest.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+module RunTest
+  ( findAllSourceFiles
+  , compileTarget
+  , runServer
+  , prettyPrintDiags
+  )
+where
+
+import           GhcMonad
+import qualified GHC
+import           Control.Monad
+import qualified Control.Concurrent.STM        as STM
+import           Data.List                      ( isPrefixOf )
+import qualified Data.Text                     as T
+import qualified Data.Map                      as Map
+import           Data.Default
+import           System.Directory               ( doesDirectoryExist
+                                                , listDirectory
+                                                , canonicalizePath
+                                                , doesFileExist
+                                                )
+import           System.FilePath
+import           Language.Haskell.LSP.Core
+import           Language.Haskell.LSP.Types
+import           Haskell.Ide.Engine.PluginsIdeMonads
+                                         hiding ( withIndefiniteProgress
+                                                , withProgress
+                                                )
+import           Haskell.Ide.Engine.GhcModuleCache
+import qualified Haskell.Ide.Engine.ModuleCache
+                                               as MC
+import qualified Haskell.Ide.Engine.Ghc        as Ghc
+
+findAllSourceFiles :: FilePath -> IO [FilePath]
+findAllSourceFiles fp = do
+  absFp <- canonicalizePath fp
+  isDir <- doesDirectoryExist absFp
+  if isDir
+    then findFilesRecursively
+      isHaskellSource
+      (\path -> any (\p -> p path) [isHidden, isSpecialDir])
+      absFp
+    else filterM doesFileExist [absFp]
+ where
+  isHaskellSource = (== ".hs") . takeExtension
+  isHidden        = ("." `isPrefixOf`) . takeFileName
+  isSpecialDir    = (== "dist-newstyle") . takeFileName
+
+findFilesRecursively
+  :: (FilePath -> Bool) -> (FilePath -> Bool) -> FilePath -> IO [FilePath]
+findFilesRecursively p exclude dir = do
+  dirContents' <- listDirectory dir
+  let dirContents = map (dir </>) dirContents'
+
+  files <- forM dirContents $ \fp -> do
+    isDirectory <- doesDirectoryExist fp
+    if isDirectory
+      then if not $ exclude fp
+        then findFilesRecursively p exclude fp
+        else return []
+      else if p fp then return [fp] else return []
+
+  return $ concat files
+
+
+-- ---------------------------------------------------------------------
+
+compileTarget
+  :: GHC.DynFlags
+  -> FilePath
+  -> IdeGhcM (IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))
+compileTarget dynFlags fp = do
+  let pubDiags _ _ _ = return ()
+  let defAction = return (mempty, mempty)
+  let action    = Ghc.setTypecheckedModule (filePathToUri fp)
+  actionResult <- MC.runActionWithContext pubDiags
+                                          dynFlags
+                                          (Just fp)
+                                          defAction
+                                          action
+  return $ join actionResult
+
+-- ---------------------------------------------------------------------
+
+runServer
+  :: Maybe FilePath
+  -> IdePlugins
+  -> [FilePath]
+  -> IO [(FilePath, IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))]
+runServer mlibdir ideplugins targets = do
+  let initialState = IdeState emptyModuleCache Map.empty Map.empty Nothing
+  stateVar <- STM.newTVarIO initialState
+
+  runIdeGhcM mlibdir ideplugins dummyLspFuncs stateVar $ do
+    dynFlags <- getSessionDynFlags
+    mapM (\fp -> (fp, ) <$> compileTarget dynFlags fp) targets
+
+-- ---------------------------------------------------------------------
+
+prettyPrintDiags
+  :: FilePath -> IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs) -> T.Text
+prettyPrintDiags fp diags = T.pack fp <> ": " <> case diags of
+  IdeResultFail IdeError { ideMessage } -> "FAILED\n\t" <> ideMessage
+  IdeResultOk (_diags, errs) ->
+    if null errs then "OK" else T.unlines (map (T.append "\t") errs)
+
+-- ---------------------------------------------------------------------
+
+dummyLspFuncs :: Default a => LspFuncs a
+dummyLspFuncs = LspFuncs
+  { clientCapabilities           = def
+  , config                       = return (Just def)
+  , sendFunc                     = const (return ())
+  , getVirtualFileFunc           = const (return Nothing)
+  , persistVirtualFileFunc       = \uri ->
+                                     return (uriToFilePath (fromNormalizedUri uri))
+  , reverseFileMapFunc           = return id
+  , publishDiagnosticsFunc       = mempty
+  , flushDiagnosticsBySourceFunc = mempty
+  , getNextReqId                 = pure (IdInt 0)
+  , rootPath                     = Nothing
+  , getWorkspaceFolders          = return Nothing
+  , withProgress                 = \_ _ f -> f (const (return ()))
+  , withIndefiniteProgress       = \_ _ f -> f
+  }

haskell-ide-engine.cabal

@@ -110,17 +110,23 @@ library
 executable hie
   hs-source-dirs:      app
   main-is:             MainHie.hs
-  other-modules:       Paths_haskell_ide_engine
+  other-modules:       Paths_haskell_ide_engine, RunTest
   autogen-modules:     Paths_haskell_ide_engine
   build-depends:       base
+                     , containers
+                     , data-default
                      , directory
                      , filepath
+                     , ghc
                      , hie-bios
                      , haskell-ide-engine
                      , haskell-lsp
+                     , haskell-lsp-types
                      , hie-plugin-api
                      , hslogger
                      , optparse-simple
+                     , stm
+                     , text
                      , yaml
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
                        -with-rtsopts=-T

src/Haskell/Ide/Engine/Options.hs

@@ -6,11 +6,13 @@ import           Options.Applicative.Simple
 data GlobalOpts = GlobalOpts
   { optDebugOn       :: Bool
   , optLogFile       :: Maybe String
-  , optLsp           :: Bool -- Kept for a while, to not break legacy clients
+  , optLsp           :: Bool
   , projectRoot      :: Maybe String
   , optBiosVerbose   :: Bool
   , optCaptureFile   :: Maybe FilePath
   , optExamplePlugin :: Bool
+  , optDryRun        :: Bool
+  , optFiles         :: [FilePath]
   } deriving (Show)
 
 globalOptsParser :: Parser GlobalOpts
@@ -53,3 +55,13 @@ globalOptsParser = GlobalOpts
   <*> switch
        ( long "example"
        <> help "Enable Example2 plugin. Useful for developers only")
+  <*> flag False True
+     (  long "dry-run"
+     <> help "Perform a dry-run of loading files. Only searches for Haskell source files to load. Does nothing if run as LSP server."
+     )
+  <*> many
+     ( argument str
+       (  metavar "FILES..."
+       <> help "Directories and Filepaths to load. Does nothing if run as LSP server.")
+     )
+