From 6391efd7cc7aac5e30ed2a01510a4ac8f99f5212 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 10 Jan 2020 19:00:05 +0100 Subject: [PATCH 1/5] Load all possible haskell source files --- app/MainHie.hs | 51 ++++++++++++++++++--- app/RunTest.hs | 97 ++++++++++++++++++++++++++++++++++++++++ haskell-ide-engine.cabal | 7 ++- 3 files changed, 149 insertions(+), 6 deletions(-) create mode 100644 app/RunTest.hs diff --git a/app/MainHie.hs b/app/MainHie.hs index dc57abea9..38de30a0a 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,39 @@ 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 "" + cliOut "" + cliOut "###################################################" + cliOut "" + cliOut $ "Cradle: " ++ cradleDisplay cradle + cliOut $ "Project Ghc version: " ++ projGhc + cliOut $ "Libdir: " ++ show mlibdir + cliOut "Searching for Haskell source files..." + targets <- findAllSourceFiles origDir + cliOut $ "Found " ++ show (length targets) ++ " Haskell source files." + cliOut "Load them all now. This may take a very long time." + cliOut "" + cliOut "###################################################" + cliOut "" + cliOut "" + loadDiagnostics <- runServer plugins' targets + + cliOut "" + cliOut "###################################################" + cliOut "###################################################" + cliOut "" + cliOut "Dumping diagnostics:" + cliOut "" + cliOut "" + mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics + cliOut "" + cliOut "" + cliOut "" + cliOut "Note: loading of 'Setup.hs' is not supported." + -- --------------------------------------------------------------------- @@ -170,4 +208,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..c843b50a3 --- /dev/null +++ b/app/RunTest.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +module RunTest + ( findAllSourceFiles + , compileTarget + , runServer + , prettyPrintDiags + ) +where + +import GhcMonad +import GHC +import qualified Data.Text as T +import System.Directory ( doesDirectoryExist + , listDirectory + , canonicalizePath + , getCurrentDirectory + ) +import Haskell.Ide.Engine.PluginsIdeMonads +import qualified Haskell.Ide.Engine.ModuleCache + as MC +import qualified Haskell.Ide.Engine.Ghc as Ghc +import System.FilePath +import Control.Monad +import Data.List ( isPrefixOf ) +import TestUtils ( runIGM ) + +findAllSourceFiles :: FilePath -> IO [FilePath] +findAllSourceFiles dir = do + absDir <- canonicalizePath dir + findFilesRecursively isHaskellSource + (\fp -> any (\p -> p fp) [isHidden, isSpecialDir]) + absDir + 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 + :: 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 + :: IdePlugins + -> [FilePath] + -> IO [(FilePath, IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))] +runServer ideplugins targets = do + cwd <- getCurrentDirectory + runIGM ideplugins (cwd "File.hs") $ 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) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 709530d4e..1f57ab4e8 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -110,18 +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 , directory , filepath + , ghc , hie-bios , haskell-ide-engine , haskell-lsp , hie-plugin-api , hslogger , optparse-simple + , text , yaml + -- TODO: this is horrible + , hie-test-utils ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints -with-rtsopts=-T if flag(pedantic) From abf9c1a33b8e63c53cf1022f677736150958ccae Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 13 Jan 2020 21:31:53 +0100 Subject: [PATCH 2/5] Add dry-run flag and optional filepaths --- app/MainHie.hs | 40 ++++++++--------- app/RunTest.hs | 75 ++++++++++++++++++++++--------- haskell-ide-engine.cabal | 5 ++- src/Haskell/Ide/Engine/Options.hs | 14 +++++- 4 files changed, 87 insertions(+), 47 deletions(-) diff --git a/app/MainHie.hs b/app/MainHie.hs index 38de30a0a..8e1cd5257 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -164,35 +164,31 @@ run opts = do Right cradle -> do projGhc <- getProjectGhcVersion cradle mlibdir <- getProjectGhcLibDir cradle - cliOut "" - cliOut "" - cliOut "###################################################" - cliOut "" + cliOut "\n\n###################################################\n" cliOut $ "Cradle: " ++ cradleDisplay cradle cliOut $ "Project Ghc version: " ++ projGhc cliOut $ "Libdir: " ++ show mlibdir cliOut "Searching for Haskell source files..." - targets <- findAllSourceFiles origDir - cliOut $ "Found " ++ show (length targets) ++ " Haskell source files." - cliOut "Load them all now. This may take a very long time." - cliOut "" - cliOut "###################################################" - cliOut "" - cliOut "" - loadDiagnostics <- runServer plugins' targets + targets <- case optFiles opts of + [] -> findAllSourceFiles origDir + xs -> concat <$> mapM findAllSourceFiles xs - cliOut "" + cliOut $ "Found " ++ show (length targets) ++ " Haskell source files.\n" cliOut "###################################################" - cliOut "###################################################" - cliOut "" - cliOut "Dumping diagnostics:" - cliOut "" - cliOut "" - mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics + cliOut "\nFound the following files:\n" + mapM_ cliOut targets cliOut "" - cliOut "" - cliOut "" - cliOut "Note: loading of 'Setup.hs' is not supported." + + unless (optDryRun opts) $ do + loadDiagnostics <- runServer mlibdir plugins' targets + + cliOut "" + cliOut "###################################################" + cliOut "###################################################" + cliOut "\nLoad them all now. This may take a very long time.\n" + cliOut "\nDumping diagnostics:\n\n" + mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics + cliOut "\n\n\nNote: loading of 'Setup.hs' is not supported." -- --------------------------------------------------------------------- diff --git a/app/RunTest.hs b/app/RunTest.hs index c843b50a3..bc06a716f 100644 --- a/app/RunTest.hs +++ b/app/RunTest.hs @@ -11,27 +11,39 @@ where import GhcMonad import 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 - , getCurrentDirectory + , 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 -import System.FilePath -import Control.Monad -import Data.List ( isPrefixOf ) -import TestUtils ( runIGM ) findAllSourceFiles :: FilePath -> IO [FilePath] -findAllSourceFiles dir = do - absDir <- canonicalizePath dir - findFilesRecursively isHaskellSource - (\fp -> any (\p -> p fp) [isHidden, isSpecialDir]) - absDir +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 @@ -74,12 +86,15 @@ compileTarget dynFlags fp = do -- --------------------------------------------------------------------- runServer - :: IdePlugins + :: Maybe FilePath + -> IdePlugins -> [FilePath] -> IO [(FilePath, IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs))] -runServer ideplugins targets = do - cwd <- getCurrentDirectory - runIGM ideplugins (cwd "File.hs") $ do +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 @@ -87,11 +102,27 @@ runServer ideplugins targets = do 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) +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 1f57ab4e8..932dc5dc6 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -114,19 +114,20 @@ executable hie 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 - -- TODO: this is horrible - , hie-test-utils ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints -with-rtsopts=-T if flag(pedantic) diff --git a/src/Haskell/Ide/Engine/Options.hs b/src/Haskell/Ide/Engine/Options.hs index 57af3cd11..d5862c0d2 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." + ) + <*> many + ( argument str + ( metavar "FILES..." + <> help "Directories and Filepaths to load.") + ) + From e56c7b7847ef95eb8424183e7f4644f9608f4ac6 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 13 Jan 2020 21:51:06 +0100 Subject: [PATCH 3/5] Qualify import of GHC lib --- app/RunTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/RunTest.hs b/app/RunTest.hs index bc06a716f..4478d7df5 100644 --- a/app/RunTest.hs +++ b/app/RunTest.hs @@ -10,7 +10,7 @@ module RunTest where import GhcMonad -import GHC +import qualified GHC import Control.Monad import qualified Control.Concurrent.STM as STM import Data.List ( isPrefixOf ) @@ -69,7 +69,7 @@ findFilesRecursively p exclude dir = do -- --------------------------------------------------------------------- compileTarget - :: DynFlags + :: GHC.DynFlags -> FilePath -> IdeGhcM (IdeResult (Ghc.Diagnostics, Ghc.AdditionalErrs)) compileTarget dynFlags fp = do From e0cac6aefc453f8474ff87c5303cb9d6995c54fd Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 17 Jan 2020 14:35:00 +0100 Subject: [PATCH 4/5] Fix location of logging message --- app/MainHie.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/MainHie.hs b/app/MainHie.hs index 8e1cd5257..564582caf 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -180,15 +180,15 @@ run opts = do 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 "\nLoad them all now. This may take a very long time.\n" cliOut "\nDumping diagnostics:\n\n" mapM_ (cliOut' . uncurry prettyPrintDiags) loadDiagnostics - cliOut "\n\n\nNote: loading of 'Setup.hs' is not supported." + cliOut "\n\nNote: loading of 'Setup.hs' is not supported." -- --------------------------------------------------------------------- From 8fce52fb28d2f63c154a109986fd0ba68cec59e8 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 18 Jan 2020 12:07:01 +0100 Subject: [PATCH 5/5] Improve help message Indicate that some options dont do anything in combination with the `--lsp` flag. We do this, because we cant express this invariant in the type-system, yet. A follow-up PR, refactoring the command line flags is needed. --- src/Haskell/Ide/Engine/Options.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Haskell/Ide/Engine/Options.hs b/src/Haskell/Ide/Engine/Options.hs index d5862c0d2..25a43fb0d 100644 --- a/src/Haskell/Ide/Engine/Options.hs +++ b/src/Haskell/Ide/Engine/Options.hs @@ -57,11 +57,11 @@ globalOptsParser = GlobalOpts <> 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." + <> 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.") + <> help "Directories and Filepaths to load. Does nothing if run as LSP server.") )