Display which cradle was used when testing for mismatching GHC versions

This commit is contained in:
Luke Lau 2019-12-16 14:17:30 +00:00
parent 43cf0d1d3e
commit eb4ce4cf3d
3 changed files with 21 additions and 17 deletions

View File

@ -15,14 +15,16 @@ import Distribution.Helper (Package, projectPackages, pUnits,
Unit, unitInfo, uiComponents, Unit, unitInfo, uiComponents,
ChEntrypoint(..)) ChEntrypoint(..))
import Distribution.Helper.Discover (findProjects, getDefaultDistDir) import Distribution.Helper.Discover (findProjects, getDefaultDistDir)
import Data.Char (toLower)
import Data.Function ((&)) import Data.Function ((&))
import Data.List (isPrefixOf) import Data.List (isPrefixOf, isInfixOf)
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M import qualified Data.Map as M
import Data.List (sortOn, find) import Data.List (sortOn, find)
import Data.Maybe (listToMaybe, mapMaybe, isJust) import Data.Maybe (listToMaybe, mapMaybe, isJust)
import Data.Ord (Down(..)) import Data.Ord (Down(..))
import Data.String (IsString(..))
import Data.Foldable (toList) import Data.Foldable (toList)
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import System.FilePath import System.FilePath
@ -680,3 +682,17 @@ ancestors dir
relativeTo :: FilePath -> [FilePath] -> Maybe FilePath relativeTo :: FilePath -> [FilePath] -> Maybe FilePath
relativeTo file sourceDirs = listToMaybe relativeTo file sourceDirs = listToMaybe
$ mapMaybe (`stripFilePath` file) sourceDirs $ mapMaybe (`stripFilePath` file) sourceDirs
-- | Returns a user facing display name for the cradle type,
-- e.g. "Stack project" or "GHC session"
cradleDisplay :: IsString a => BIOS.Cradle -> a
cradleDisplay cradle = fromString result
where
result
| "stack" `isInfixOf` name = "Stack project"
| "cabal-v1" `isInfixOf` name = "Cabal (V1) project"
| "cabal" `isInfixOf` name = "Cabal project"
| "direct" `isInfixOf` name = "GHC session"
| otherwise = "project"
name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle)

View File

@ -32,9 +32,7 @@ import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Control.Monad.Trans.Free import Control.Monad.Trans.Free
import Data.Char
import Data.Dynamic (toDyn, fromDynamic, Dynamic) import Data.Dynamic (toDyn, fromDynamic, Dynamic)
import Data.List
import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf) import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
@ -52,11 +50,10 @@ import qualified Data.Text as Text
import qualified Data.Yaml as Yaml import qualified Data.Yaml as Yaml
import qualified HIE.Bios as BIOS import qualified HIE.Bios as BIOS
import qualified HIE.Bios.Ghc.Api as BIOS import qualified HIE.Bios.Ghc.Api as BIOS
import qualified HIE.Bios.Types as BIOS
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Haskell.Ide.Engine.ArtifactMap import Haskell.Ide.Engine.ArtifactMap
import Haskell.Ide.Engine.Cradle (findLocalCradle) import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
import Haskell.Ide.Engine.TypeMap import Haskell.Ide.Engine.TypeMap
import Haskell.Ide.Engine.GhcModuleCache import Haskell.Ide.Engine.GhcModuleCache
import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.MultiThreadState
@ -157,16 +154,6 @@ loadCradle iniDynFlags (NewCradle fp) def action = do
} }
where where
-- | Get a user facing display name for the cradle type.
cradleDisplay :: BIOS.Cradle -> Text.Text
cradleDisplay cradle
| "stack" `isInfixOf` name = "Stack project"
| "cabal-v1" `isInfixOf` name = "Cabal (V1) project"
| "cabal" `isInfixOf` name = "Cabal project"
| "direct" `isInfixOf` name = "GHC session"
| otherwise = "project"
where name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle)
-- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`. -- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`.
-- Reports its progress to the client. -- Reports its progress to the client.
initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m) initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m)

View File

@ -38,7 +38,7 @@ import qualified Data.SortedList as SL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding import Data.Text.Encoding
import qualified Data.Yaml as Yaml import qualified Data.Yaml as Yaml
import Haskell.Ide.Engine.Cradle (findLocalCradle) import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.Config
import qualified Haskell.Ide.Engine.Ghc as HIE import qualified Haskell.Ide.Engine.Ghc as HIE
import Haskell.Ide.Engine.LSP.CodeActions import Haskell.Ide.Engine.LSP.CodeActions
@ -411,7 +411,8 @@ reactor inp diagIn = do
Just cradle -> do Just cradle -> do
projGhcVersion <- liftIO $ getProjectGhcVersion cradle projGhcVersion <- liftIO $ getProjectGhcVersion cradle
when (projGhcVersion /= hieGhcVersion) $ do when (projGhcVersion /= hieGhcVersion) $ do
let msg = T.pack $ "Mismatching GHC versions: Project is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
" is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
++ "\nYou may want to use hie-wrapper. Check the README for more information" ++ "\nYou may want to use hie-wrapper. Check the README for more information"
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg