haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-10-05 12:49:07 +03:00
Code Issues Projects Releases Wiki Activity

Fix DisplayTHWarning error (#2895)

Browse Source 
This used to fail in the CLI with

```
Internal error, getIdeGlobalExtras, no entry for DisplayTHWarning
```
This commit is contained in:
Pepe Iborra 2022-05-08 22:10:01 +02:00 committed by GitHub
parent 6524122927
commit 9e1738e8c5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 22 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -835,9 +835,13 @@ instance IsIdeGlobal DisplayTHWarning
getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules ()
getModSummaryRule displayTHWarning recorder = do
menv <- lspEnv <$> getShakeExtrasRules
forM_ menv $ \env -> do
case menv of
Just env -> do
displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning
addIdeGlobal (DisplayTHWarning displayItOnce)
Nothing -> do
logItOnce <- liftIO $ once $ putStrLn ""
addIdeGlobal (DisplayTHWarning logItOnce)
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do
session' <- hscEnv <$> use_ GhcSession f
@ -1118,13 +1122,16 @@ instance Default RulesConfig where
displayTHWarning
| not isWindows && not hostIsDynamic = do
LSP.sendNotification SWindowShowMessage $
ShowMessageParams MtInfo $ T.unwords
[ "This HLS binary does not support Template Haskell."
, "Follow the [instructions](" <> templateHaskellInstructions <> ")"
, "to build an HLS binary with support for Template Haskell."
]
ShowMessageParams MtInfo thWarningMessage
| otherwise = return ()
thWarningMessage :: T.Text
thWarningMessage = T.unwords
[ "This HLS binary does not support Template Haskell."
, "Follow the [instructions](" <> templateHaskellInstructions <> ")"
, "to build an HLS binary with support for Template Haskell."
]
-- | A rule that wires per-file rules together
mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules ()
mainRule recorder RulesConfig{..} = do

18
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -99,10 +99,10 @@ import Data.EnumMap.Strict (EnumMap)
import qualified Data.EnumMap.Strict as EM
import Data.Foldable (for_, toList)
import Data.Functor ((<&>))
import Data.Hashable
import qualified Data.HashMap.Strict as HMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HSet
import Data.Hashable
import Data.IORef
import Data.List.Extra (foldl', partition,
takeEnd)
@ -148,12 +148,12 @@ import Development.IDE.Types.KnownTargets
import Development.IDE.Types.Location
import Development.IDE.Types.Logger hiding (Priority)
import qualified Development.IDE.Types.Logger as Logger
import Development.IDE.Types.Monitoring (Monitoring (..))
import Development.IDE.Types.Options
import Development.IDE.Types.Shake
import qualified Focus
import GHC.Fingerprint
import Language.LSP.Types.Capabilities
import OpenTelemetry.Eventlog
import GHC.Stack (HasCallStack)
import HieDb.Types
import Ide.Plugin.Config
import qualified Ide.PluginUtils as HLS
@ -162,13 +162,14 @@ import Language.LSP.Diagnostics
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
import qualified Language.LSP.Types as LSP
import Language.LSP.Types.Capabilities
import Language.LSP.VFS
import qualified "list-t" ListT
import OpenTelemetry.Eventlog
import qualified StmContainers.Map as STM
import System.FilePath hiding (makeRelative)
import System.IO.Unsafe (unsafePerformIO)
import System.IO.Unsafe (unsafePerformIO)
import System.Time.Extra
import Development.IDE.Types.Monitoring (Monitoring(..))
data Log
= LogCreateHieDbExportsMapStart
@ -341,7 +342,7 @@ addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
Nothing -> HMap.insert ty (toDyn x) mp
getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a
getIdeGlobalExtras ShakeExtras{globals} = do
let typ = typeRep (Proxy :: Proxy a)
x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals
@ -351,13 +352,12 @@ getIdeGlobalExtras ShakeExtras{globals} = do
| otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"
Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ
getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a
getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
getIdeGlobalState = getIdeGlobalExtras . shakeExtras
newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
instance IsIdeGlobal GlobalIdeOptions
@ -756,7 +756,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
-- Take a new VFS snapshot
case vfsMod of
VFSUnmodified -> pure ()
VFSUnmodified -> pure ()
VFSModified vfs -> atomically $ writeTVar vfsVar vfs
IdeOptions{optRunSubset} <- getIdeOptionsIO extras