Merge upstream master

Author: Avi-D-coder

README.md

@@ -14,10 +14,7 @@
 [appveyor]: https://ci.appveyor.com/project/Bubba/haskell-ide-engine-74xec
 
 
-This project aims to be __the universal interface__ to __a growing number of Haskell tools__, providing a __full-featured and easy to query backend__ for editors and IDEs that require Haskell-specific functionality.
-
-__We are currently focusing on using the [Language Server Protocol](https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md) as the interface via which
-we talk to clients.__
+This project aims to be __the universal interface__ to __a growing number of Haskell tools__, providing a __fully-featured [Language Server Protocol](https://github.com/Microsoft/language-server-protocol/blob/master/protocol.md) server__ for editors and IDEs that require Haskell-specific functionality.
 
 - [Haskell IDE Engine (HIE)](#haskell-ide-engine-hie)
   - [Features](#features)
@@ -545,9 +542,10 @@ Then issue `:CocConfig` and add the following to your Coc config file.
   "haskell": {
     "command": "hie-wrapper",
     "rootPatterns": [
-      ".stack.yaml",
-      "cabal.config",
-      "package.yaml"
+      "*.cabal",
+      "stack.yaml",
+      "cabal.project",
+      "package.yaml",
     ],
     "filetypes": [
       "hs",

app/MainHie.hs

@@ -38,6 +38,7 @@ import           Haskell.Ide.Engine.Plugin.Package
 import           Haskell.Ide.Engine.Plugin.Pragmas
 import           Haskell.Ide.Engine.Plugin.Floskell
 import           Haskell.Ide.Engine.Plugin.Generic
+import           Haskell.Ide.Engine.Plugin.GhcMod
 
 -- ---------------------------------------------------------------------
 
@@ -59,6 +60,7 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins
       , pragmasDescriptor     "pragmas"
       , floskellDescriptor    "floskell"
       , genericDescriptor     "generic"
+      , ghcmodDescriptor      "ghcmod"
       ]
     examplePlugins =
       [example2Descriptor "eg2"

haskell-ide-engine.cabal

@@ -37,6 +37,7 @@ library
                        Haskell.Ide.Engine.Plugin.Package.Compat
                        Haskell.Ide.Engine.Plugin.Pragmas
                        Haskell.Ide.Engine.Plugin.Generic
+                       Haskell.Ide.Engine.Plugin.GhcMod
                        Haskell.Ide.Engine.Scheduler
                        Haskell.Ide.Engine.Support.FromHaRe
                        Haskell.Ide.Engine.Support.Hoogle
@@ -180,6 +181,7 @@ test-suite unit-test
                        DiffSpec
                        ExtensibleStateSpec
                        GenericPluginSpec
+                       GhcModPluginSpec
                        -- HaRePluginSpec
                        HooglePluginSpec
                        JsonSpec
@@ -245,6 +247,8 @@ test-suite plugin-dispatcher-test
   main-is:             Main.hs
   build-depends:       base
                      , data-default
+                     , directory
+                     , filepath
                      , haskell-ide-engine
                      , haskell-lsp-types
                      , hie-plugin-api
@@ -287,7 +291,7 @@ test-suite func-test
                      , data-default
                      , directory
                      , filepath
-                     , lsp-test >= 0.9.0.0
+                     , lsp-test >= 0.10.0.0
                      , haskell-ide-engine
                      , haskell-lsp-types == 0.19.*
                      , haskell-lsp == 0.19.*

hie-plugin-api/Haskell/Ide/Engine/Cradle.hs

@@ -17,19 +17,20 @@ import           Distribution.Helper (Package, projectPackages, pUnits,
 import           Distribution.Helper.Discover (findProjects, getDefaultDistDir)
 import           Data.Char (toLower)
 import           Data.Function ((&))
-import           Data.List (isPrefixOf, isInfixOf)
+import           Data.List (isPrefixOf, isInfixOf, sortOn, find)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as M
-import           Data.List (sortOn, find)
 import           Data.Maybe (listToMaybe, mapMaybe, isJust)
 import           Data.Ord (Down(..))
 import           Data.String (IsString(..))
+import qualified Data.Text as T
 import           Data.Foldable (toList)
-import           Control.Exception (IOException, try)
+import           Control.Exception
 import           System.FilePath
 import           System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
 import           System.Exit
+import           System.Process (readCreateProcessWithExitCode, shell)
 
 -- | Find the cradle that the given File belongs to.
 --
@@ -57,6 +58,98 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None
   . BIOS.actionName
   . BIOS.cradleOptsProg
 
+  -- | Check if the given cradle is a cabal cradle.
+-- This might be used to determine the GHC version to use on the project.
+-- If it is a stack-cradle, we have to use `stack path --compiler-exe`
+-- otherwise we may ask `ghc` directly what version it is.
+isCabalCradle :: Cradle -> Bool
+isCabalCradle =
+  (`elem`
+    ["cabal"
+    , "Cabal-Helper-Cabal-V1"
+    , "Cabal-Helper-Cabal-V2"
+    , "Cabal-Helper-Cabal-V1-Dir"
+    , "Cabal-Helper-Cabal-V2-Dir"
+    , "Cabal-Helper-Cabal-None"
+    ]
+  )
+  . BIOS.actionName
+  . BIOS.cradleOptsProg
+
+-- | Execute @ghc@ that is based on the given cradle.
+-- Output must be a single line. If an error is raised, e.g. the command
+-- failed, a @Nothing@ is returned.
+-- The exact error is written to logs.
+--
+-- E.g. for a stack cradle, we use `stack ghc` and for a cabal cradle
+-- we are taking the @ghc@ that is on the path.
+execProjectGhc :: Cradle -> [String] -> IO (Maybe String)
+execProjectGhc crdl args = do
+  isStackInstalled <- isJust <$> findExecutable "stack"
+  -- isCabalInstalled <- isJust <$> findExecutable "cabal"
+  ghcOutput <- if isStackCradle crdl && isStackInstalled
+    then do
+      logm "Use Stack GHC"
+      catch (Just <$> tryCommand stackCmd) $ \(_ :: IOException) -> do
+        errorm $ "Command `" ++ stackCmd ++"` failed."
+        execWithGhc
+    -- The command `cabal v2-exec -v0 ghc` only works if the project has been
+    -- built already.
+    -- This command must work though before the project is build.
+    -- Therefore, fallback to "ghc" on the path.
+    --
+    -- else if isCabalCradle crdl && isCabalInstalled then do
+    --   let cmd = "cabal v2-exec -v0 ghc -- " ++ unwords args
+    --   catch (Just <$> tryCommand cmd) $ \(_ ::IOException) -> do
+    --     errorm $ "Command `" ++ cmd ++ "` failed."
+    --     return Nothing
+    else do
+      logm "Use Plain GHC"
+      execWithGhc
+  debugm $ "GHC Output: \"" ++ show ghcOutput ++ "\""
+  return ghcOutput
+  where
+    stackCmd = "stack ghc -- " ++ unwords args
+    plainCmd = "ghc " ++ unwords args
+
+    execWithGhc =
+      catch (Just <$> tryCommand plainCmd) $ \(_ :: IOException) -> do
+        errorm $ "Command `" ++ plainCmd ++"` failed."
+        return Nothing
+
+tryCommand :: String -> IO String
+tryCommand cmd = do
+  (code, sout, serr) <- readCreateProcessWithExitCode (shell cmd) ""
+  case code of
+    ExitFailure e -> do
+      let errmsg = concat
+            [ "`"
+            , cmd
+            , "`: Exit failure: "
+            , show e
+            , ", stdout: "
+            , sout
+            , ", stderr: "
+            , serr
+            ]
+      errorm errmsg
+      throwIO $ userError errmsg
+
+    ExitSuccess -> return $ T.unpack . T.strip . head . T.lines $ T.pack sout
+
+
+-- | Get the directory of the libdir based on the project ghc.
+getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
+getProjectGhcLibDir crdl =
+  execProjectGhc crdl ["--print-libdir"] >>= \case
+    Nothing -> do
+      logm "Could not obtain the libdir."
+      return Nothing
+    mlibdir -> return mlibdir
+
+  -- ---------------------------------------------------------------------
+
+
 {- | Finds a Cabal v2-project, Cabal v1-project or a Stack project
 relative to the given FilePath.
 Cabal v2-project and Stack have priority over Cabal v1-project.

hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs

@@ -37,7 +37,7 @@ warningm :: MonadIO m => String -> m ()
 warningm s = liftIO $ warningM "hie" s
 
 errorm :: MonadIO m => String -> m ()
-errorm s = liftIO $ warningM "hie" s
+errorm s = liftIO $ errorM "hie" s
 
 -- ---------------------------------------------------------------------
 -- Extensible state, based on

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -125,9 +125,8 @@ import           Data.Typeable                  ( Typeable )
 
 import System.Directory
 import GhcMonad
-import qualified HIE.Bios.Ghc.Api as BIOS
 import           GHC.Generics
-import           GHC                            ( HscEnv )
+import           GHC                            ( HscEnv, runGhcT )
 import Exception
 
 import           Haskell.Ide.Engine.Compat
@@ -350,10 +349,10 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c)
 type IdeGhcM = GhcT IdeM
 
 -- | Run an IdeGhcM with Cradle found from the current directory
-runIdeGhcM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
-runIdeGhcM plugins mlf stateVar f = do
-  env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
-  flip runReaderT stateVar $ flip runReaderT env $ BIOS.withGhcT f
+runIdeGhcM :: Maybe FilePath -> IdePlugins -> Core.LspFuncs Config -> TVar IdeState -> IdeGhcM a -> IO a
+runIdeGhcM mlibdir plugins lf stateVar f = do
+  env <- IdeEnv <$> pure lf <*> getProcessID <*> pure plugins
+  flip runReaderT stateVar $ flip runReaderT env $ runGhcT mlibdir f
 
 -- | A computation that is deferred until the module is cached.
 -- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed
@@ -363,14 +362,14 @@ type IdeDeferM = FreeT Defer IdeM
 type IdeM = ReaderT IdeEnv (MultiThreadState IdeState)
 
 -- | Run an IdeM
-runIdeM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a
-runIdeM plugins mlf stateVar f = do
-  env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
+runIdeM :: IdePlugins -> Core.LspFuncs Config -> TVar IdeState -> IdeM a -> IO a
+runIdeM plugins lf stateVar f = do
+  env <- IdeEnv <$> pure lf <*> getProcessID <*> pure plugins
   -- TODO: AZ run a single ReaderT, with a composite R.
   flip runReaderT stateVar $ runReaderT f env
 
 data IdeEnv = IdeEnv
-  { ideEnvLspFuncs :: Maybe (Core.LspFuncs Config)
+  { ideEnvLspFuncs :: Core.LspFuncs Config
   -- | The pid of this instance of hie
   , ideEnvPidCache :: Int
   , idePlugins  :: IdePlugins
@@ -390,18 +389,12 @@ instance MonadIde IdeGhcM where
   getIdeEnv = lift ask
 
 getRootPath :: MonadIde m => m (Maybe FilePath)
-getRootPath = do
-  mlf <- ideEnvLspFuncs <$> getIdeEnv
-  case mlf of
-    Just lf -> return (Core.rootPath lf)
-    Nothing -> return Nothing
+getRootPath = Core.rootPath . ideEnvLspFuncs <$> getIdeEnv
 
 getVirtualFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe VirtualFile)
 getVirtualFile uri = do
-  mlf <- ideEnvLspFuncs <$> getIdeEnv
-  case mlf of
-    Just lf -> liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri)
-    Nothing -> return Nothing
+  lf <- ideEnvLspFuncs <$> getIdeEnv
+  liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri)
 
 -- | Worker function for persistVirtualFile without monad constraints.
 --
@@ -413,19 +406,15 @@ persistVirtualFile' lf uri = Core.persistVirtualFileFunc lf (toNormalizedUri uri
 
 reverseFileMap :: (MonadIde m, MonadIO m) => m (FilePath -> FilePath)
 reverseFileMap = do
-    mlf <- ideEnvLspFuncs <$> getIdeEnv
-    case mlf of
-      Just lf -> liftIO $ Core.reverseFileMapFunc lf
-      Nothing -> return id
+  lf <- ideEnvLspFuncs <$> getIdeEnv
+  liftIO $ Core.reverseFileMapFunc lf
 
 -- | Get the location of the virtual file persisted to the file system associated
 -- to the given Uri.
 getPersistedFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe FilePath)
 getPersistedFile uri = do
-  mlf <- ideEnvLspFuncs <$> getIdeEnv
-  case mlf of
-    Just lf -> liftIO $ persistVirtualFile' lf uri
-    Nothing -> return $ uriToFilePath uri
+  lf <- ideEnvLspFuncs <$> getIdeEnv
+  liftIO $ persistVirtualFile' lf uri
 
 -- | Execute an action on the temporary file associated to the given FilePath.
 -- If the file is not in the current Virtual File System, the given action is not executed
@@ -439,17 +428,11 @@ withMappedFile fp m k = do
 
 getConfig :: (MonadIde m, MonadIO m) => m Config
 getConfig = do
-  mlf <- ideEnvLspFuncs <$> getIdeEnv
-  case mlf of
-    Just lf -> fromMaybe def <$> liftIO (Core.config lf)
-    Nothing -> return def
+  lf <- ideEnvLspFuncs <$> getIdeEnv
+  fromMaybe def <$> liftIO (Core.config lf)
 
 getClientCapabilities :: MonadIde m => m ClientCapabilities
-getClientCapabilities = do
-  mlf <- ideEnvLspFuncs <$> getIdeEnv
-  case mlf of
-    Just lf -> return (Core.clientCapabilities lf)
-    Nothing -> return def
+getClientCapabilities = Core.clientCapabilities . ideEnvLspFuncs <$> getIdeEnv
 
 getPlugins :: MonadIde m => m IdePlugins
 getPlugins = idePlugins <$> getIdeEnv
@@ -462,10 +445,7 @@ withProgress :: (MonadIde m , MonadIO m, MonadBaseControl IO m)
              -> ((Core.Progress -> IO ()) -> m a) -> m a
 withProgress t c f = do
   lf <- ideEnvLspFuncs <$> getIdeEnv
-  let mWp = Core.withProgress <$> lf
-  case mWp of
-    Nothing -> f (const $ return ())
-    Just wp -> control $ \run -> wp t c $ \update -> run (f update)
+  control $ \run -> Core.withProgress lf t c $ \update -> run (f update)
 
 
 -- | 'withIndefiniteProgress' @title cancellable f@ is the same as the 'withProgress' but for tasks
@@ -474,10 +454,7 @@ withIndefiniteProgress :: (MonadIde m, MonadBaseControl IO m)
                        => T.Text -> Core.ProgressCancellable -> m a -> m a
 withIndefiniteProgress t c f = do
   lf <- ideEnvLspFuncs <$> getIdeEnv
-  let mWp = Core.withIndefiniteProgress <$> lf
-  case mWp of
-    Nothing -> f
-    Just wp -> control $ \run -> wp t c (run f)
+  control $ \run -> Core.withIndefiniteProgress lf t c (run f)
 
 data IdeState = IdeState
   { moduleCache :: !GhcModuleCache

hie-plugin-api/hie-plugin-api.cabal

@@ -56,6 +56,7 @@ library
                      , unliftio
                      , monad-control
                      , mtl
+                     , process
                      , stm
                      , syb
                      , text