diff --git a/app/MainHie.hs b/app/MainHie.hs index dc57abea9..564582caf 100644 --- a/app/MainHie.hs +++ b/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 + -- --------------------------------------------------------------------- diff --git a/app/RunTest.hs b/app/RunTest.hs new file mode 100644 index 000000000..4478d7df5 --- /dev/null +++ b/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 + } diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 709530d4e..932dc5dc6 100644 --- a/haskell-ide-engine.cabal +++ b/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 diff --git a/src/Haskell/Ide/Engine/Options.hs b/src/Haskell/Ide/Engine/Options.hs index 57af3cd11..25a43fb0d 100644 --- a/src/Haskell/Ide/Engine/Options.hs +++ b/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.") + ) +