ghcide 1.4.0.3 → 1.4.1.0
raw patch · 34 files changed
+639/−507 lines, 34 filesdep ~extradep ~ghc-api-compatdep ~hls-plugin-apiPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: extra, ghc-api-compat, hls-plugin-api, implicit-hie-cradle, lsp-types
API changes (from Hackage documentation)
- Development.IDE.GHC.Compat: mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
- Development.IDE.Main: instance GHC.Show.Show Development.IDE.Main.IdeCommand
+ Development.IDE: GHC810 :: GhcVersion
+ Development.IDE: GHC86 :: GhcVersion
+ Development.IDE: GHC88 :: GhcVersion
+ Development.IDE: GHC90 :: GhcVersion
+ Development.IDE: data GhcVersion
+ Development.IDE: ghcVersion :: GhcVersion
+ Development.IDE.GHC.Compat: GHC810 :: GhcVersion
+ Development.IDE.GHC.Compat: GHC86 :: GhcVersion
+ Development.IDE.GHC.Compat: GHC88 :: GhcVersion
+ Development.IDE.GHC.Compat: GHC90 :: GhcVersion
+ Development.IDE.GHC.Compat: data GhcVersion
+ Development.IDE.GHC.Compat: ghcVersion :: GhcVersion
+ Development.IDE.GHC.Compat: ghcVersionStr :: String
+ Development.IDE.GHC.Compat: instance GHC.Classes.Eq Development.IDE.GHC.Compat.GhcVersion
+ Development.IDE.GHC.Compat: instance GHC.Classes.Ord Development.IDE.GHC.Compat.GhcVersion
+ Development.IDE.GHC.Compat: instance GHC.Show.Show Development.IDE.GHC.Compat.GhcVersion
+ Development.IDE.GHC.Compat: unitString :: Unit -> String
+ Development.IDE.GHC.Orphans: instance Data.Hashable.Class.Hashable OccName.OccName
+ Development.IDE.GHC.Orphans: instance GHC.Show.Show OccName.OccName
+ Development.IDE.Main: PrintDefaultConfig :: Command
+ Development.IDE.Main: PrintExtensionSchema :: Command
+ Development.IDE.Plugin.CodeAction: newImport :: Text -> Maybe Text -> Maybe Text -> Bool -> NewImport
+ Development.IDE.Plugin.CodeAction: newImportToEdit :: NewImport -> ParsedSource -> Maybe (Text, TextEdit)
+ Development.IDE.Plugin.Completions.Types: [anyQualCompls] :: CachedCompletions -> [Maybe Text -> CompItem]
- Development.IDE: Plugin :: Rules () -> Handlers (ServerM c) -> DynFlagsModifications -> Plugin c
+ Development.IDE: Plugin :: Rules () -> Handlers (ServerM c) -> (c -> DynFlagsModifications) -> Plugin c
- Development.IDE: [pluginModifyDynflags] :: Plugin c -> DynFlagsModifications
+ Development.IDE: [pluginModifyDynflags] :: Plugin c -> c -> DynFlagsModifications
- Development.IDE.GHC.ExactPrint: genericGraftWithLargestM :: forall m a ast. (Monad m, Data a, Typeable ast) => Proxy (Located ast) -> SrcSpan -> (DynFlags -> GenericM (TransformT m)) -> Graft m a
+ Development.IDE.GHC.ExactPrint: genericGraftWithLargestM :: forall m a ast. (Monad m, Data a, Typeable ast) => Proxy (Located ast) -> SrcSpan -> (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a
- Development.IDE.GHC.ExactPrint: genericGraftWithSmallestM :: forall m a ast. (Monad m, Data a, Typeable ast) => Proxy (Located ast) -> SrcSpan -> (DynFlags -> GenericM (TransformT m)) -> Graft m a
+ Development.IDE.GHC.ExactPrint: genericGraftWithSmallestM :: forall m a ast. (Monad m, Data a, Typeable ast) => Proxy (Located ast) -> SrcSpan -> (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a
- Development.IDE.Import.FindImports: locateModule :: MonadIO m => DynFlags -> [(InstalledUnitId, DynFlags)] -> [String] -> (ModuleName -> NormalizedFilePath -> m Bool) -> Located ModuleName -> Maybe FastString -> Bool -> m (Either [FileDiagnostic] Import)
+ Development.IDE.Import.FindImports: locateModule :: MonadIO m => DynFlags -> [(InstalledUnitId, DynFlags)] -> [String] -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Located ModuleName -> Maybe FastString -> Bool -> m (Either [FileDiagnostic] Import)
- Development.IDE.Import.FindImports: locateModuleFile :: MonadIO m => [[FilePath]] -> [String] -> (ModuleName -> NormalizedFilePath -> m Bool) -> Bool -> ModuleName -> m (Maybe NormalizedFilePath)
+ Development.IDE.Import.FindImports: locateModuleFile :: MonadIO m => [[FilePath]] -> [String] -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName -> m (Maybe NormalizedFilePath)
- Development.IDE.Main: Custom :: FilePath -> IdeCommand -> Command
+ Development.IDE.Main: Custom :: FilePath -> IdeCommand IdeState -> Command
- Development.IDE.Main: IdeCommand :: (IdeState -> IO ()) -> IdeCommand
+ Development.IDE.Main: IdeCommand :: (state -> IO ()) -> IdeCommand state
- Development.IDE.Main: [ideCommand] :: Command -> IdeCommand
+ Development.IDE.Main: [ideCommand] :: Command -> IdeCommand IdeState
- Development.IDE.Main: commandP :: Parser Command
+ Development.IDE.Main: commandP :: IdePlugins IdeState -> Parser Command
- Development.IDE.Main: newtype IdeCommand
+ Development.IDE.Main: newtype IdeCommand state
- Development.IDE.Plugin: Plugin :: Rules () -> Handlers (ServerM c) -> DynFlagsModifications -> Plugin c
+ Development.IDE.Plugin: Plugin :: Rules () -> Handlers (ServerM c) -> (c -> DynFlagsModifications) -> Plugin c
- Development.IDE.Plugin: [pluginModifyDynflags] :: Plugin c -> DynFlagsModifications
+ Development.IDE.Plugin: [pluginModifyDynflags] :: Plugin c -> c -> DynFlagsModifications
- Development.IDE.Plugin.Completions.Types: CC :: [Text] -> [CompItem] -> QualCompls -> [Text] -> CachedCompletions
+ Development.IDE.Plugin.Completions.Types: CC :: [Text] -> [CompItem] -> QualCompls -> [Maybe Text -> CompItem] -> [Text] -> CachedCompletions
- Development.IDE.Spans.AtPoint: atPoint :: IdeOptions -> HieAstResult -> DocAndKindMap -> Position -> Maybe (Maybe Range, [Text])
+ Development.IDE.Spans.AtPoint: atPoint :: IdeOptions -> HieAstResult -> DocAndKindMap -> DynFlags -> Position -> Maybe (Maybe Range, [Text])
- Development.IDE.Types.Exports: IdentInfo :: !Text -> Text -> !Maybe Text -> !Bool -> !Text -> IdentInfo
+ Development.IDE.Types.Exports: IdentInfo :: !OccName -> Text -> !Maybe Text -> !Bool -> !Text -> IdentInfo
- Development.IDE.Types.Exports: [name] :: IdentInfo -> !Text
+ Development.IDE.Types.Exports: [name] :: IdentInfo -> !OccName
- Development.IDE.Types.Options: IdeOptions :: (ParsedSource -> IdePreprocessedSource) -> Action IdeGhcSession -> IdePkgLocationOptions -> [String] -> Maybe FilePath -> IdeOTMemoryProfiling -> IdeTesting -> IdeReportProgress -> String -> Bool -> [Text] -> IdeDefer -> IO Bool -> IO CheckParents -> OptHaddockParse -> DynFlagsModifications -> ShakeOptions -> (forall a. Typeable a => a -> Bool) -> ProgressReportingStyle -> Bool -> IdeOptions
+ Development.IDE.Types.Options: IdeOptions :: (ParsedSource -> IdePreprocessedSource) -> Action IdeGhcSession -> IdePkgLocationOptions -> [String] -> Maybe FilePath -> IdeOTMemoryProfiling -> IdeTesting -> IdeReportProgress -> String -> Bool -> [Text] -> IdeDefer -> IO Bool -> IO CheckParents -> OptHaddockParse -> (Config -> DynFlagsModifications) -> ShakeOptions -> (forall a. Typeable a => a -> Bool) -> ProgressReportingStyle -> Bool -> IdeOptions
- Development.IDE.Types.Options: [optModifyDynFlags] :: IdeOptions -> DynFlagsModifications
+ Development.IDE.Types.Options: [optModifyDynFlags] :: IdeOptions -> Config -> DynFlagsModifications
- Generics.SYB.GHC: genericIsSubspan :: forall ast. Typeable ast => Proxy (Located ast) -> SrcSpan -> GenericQ (Maybe Bool)
+ Generics.SYB.GHC: genericIsSubspan :: forall ast. Typeable ast => Proxy (Located ast) -> SrcSpan -> GenericQ (Maybe (Bool, ast))
- Generics.SYB.GHC: largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
+ Generics.SYB.GHC: largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
- Generics.SYB.GHC: smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m
+ Generics.SYB.GHC: smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m
Files
- bench/lib/Experiments.hs +35/−1
- exe/Arguments.hs +17/−19
- exe/Main.hs +4/−31
- ghcide.cabal +28/−8
- session-loader/Development/IDE/Session.hs +6/−10
- src/Development/IDE.hs +2/−0
- src/Development/IDE/Core/Actions.hs +5/−2
- src/Development/IDE/Core/Compile.hs +1/−1
- src/Development/IDE/Core/PositionMapping.hs +2/−1
- src/Development/IDE/Core/Rules.hs +23/−8
- src/Development/IDE/GHC/Compat.hs +32/−10
- src/Development/IDE/GHC/ExactPrint.hs +2/−2
- src/Development/IDE/GHC/Orphans.hs +6/−0
- src/Development/IDE/Import/FindImports.hs +7/−7
- src/Development/IDE/LSP/Outline.hs +7/−1
- src/Development/IDE/Main.hs +45/−11
- src/Development/IDE/Plugin.hs +1/−1
- src/Development/IDE/Plugin/CodeAction.hs +18/−3
- src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +2/−1
- src/Development/IDE/Plugin/Completions.hs +30/−8
- src/Development/IDE/Plugin/Completions/Logic.hs +43/−5
- src/Development/IDE/Plugin/Completions/Types.hs +9/−6
- src/Development/IDE/Plugin/HLS.hs +8/−1
- src/Development/IDE/Spans/AtPoint.hs +13/−2
- src/Development/IDE/Types/Exports.hs +31/−23
- src/Development/IDE/Types/Options.hs +1/−1
- src/Generics/SYB/GHC.hs +9/−9
- test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs +0/−50
- test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +0/−50
- test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +0/−50
- test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +0/−50
- test/exe/Main.hs +191/−100
- test/src/Development/IDE/Test.hs +14/−35
- test/src/Development/IDE/Test/Diagnostic.hs +47/−0
bench/lib/Experiments.hs view
@@ -31,11 +31,15 @@ import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test+import Development.IDE.Test.Diagnostic import Development.Shake (CmdOption (Cwd, FileStdout), cmd_) import Experiments.Types import Language.LSP.Test-import Language.LSP.Types+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative@@ -169,6 +173,36 @@ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [ FileEvent (filePathToUri "hie.yaml") FcChanged ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)+ ),+ ---------------------------------------------------------------------------------------+ benchWithSetup+ "hole fit suggestions"+ ( mapM_ $ \DocumentPositions{..} -> do+ let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent+ { _range = Just Range {_start = bottom, _end = bottom}+ , _rangeLength = Nothing, _text = t}+ bottom = Position maxBound 0+ t = T.unlines+ [""+ ,"holef :: [Int] -> [Int]"+ ,"holef = _"+ ,""+ ,"holeg :: [()] -> [()]"+ ,"holeg = _"+ ]+ changeDoc doc [edit]+ )+ (\docs -> do+ forM_ docs $ \DocumentPositions{..} ->+ changeDoc doc [charEdit stringLiteralP]+ void waitForDiagnostics+ waitForProgressDone+ flip allM docs $ \DocumentPositions{..} -> do+ bottom <- pred . length . T.lines <$> documentContents doc+ diags <- getCurrentDiagnostics doc+ case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of+ Nothing -> pure True+ Just _err -> pure False ) ]
exe/Arguments.hs view
@@ -3,43 +3,41 @@ module Arguments(Arguments(..), getArguments) where +import Development.IDE (IdeState) import Development.IDE.Main (Command (..), commandP)+import Ide.Types (IdePlugins) import Options.Applicative data Arguments = Arguments- {argsCwd :: Maybe FilePath- ,argsVersion :: Bool- ,argsVSCodeExtensionSchema :: Bool- ,argsDefaultConfig :: Bool- ,argsShakeProfiling :: Maybe FilePath- ,argsOTMemoryProfiling :: Bool- ,argsTesting :: Bool- ,argsDisableKick :: Bool- ,argsThreads :: Int- ,argsVerbose :: Bool- ,argsCommand :: Command+ {argsCwd :: Maybe FilePath+ ,argsVersion :: Bool+ ,argsShakeProfiling :: Maybe FilePath+ ,argsOTMemoryProfiling :: Bool+ ,argsTesting :: Bool+ ,argsDisableKick :: Bool+ ,argsThreads :: Int+ ,argsVerbose :: Bool+ ,argsCommand :: Command } -getArguments :: IO Arguments-getArguments = execParser opts+getArguments :: IdePlugins IdeState -> IO Arguments+getArguments plugins = execParser opts where- opts = info (arguments <**> helper)+ opts = info (arguments plugins <**> helper) ( fullDesc <> header "ghcide - the core of a Haskell IDE") -arguments :: Parser Arguments-arguments = Arguments+arguments :: IdePlugins IdeState -> Parser Arguments+arguments plugins = Arguments <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") <*> switch (long "version" <> help "Show ghcide and GHC versions")- <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")- <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output")- <*> (commandP <|> lspCommand <|> checkCommand)+ <*> (commandP plugins <|> lspCommand <|> checkCommand) where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")
exe/Main.hs view
@@ -7,19 +7,11 @@ import Arguments (Arguments (..), getArguments)-import Control.Concurrent.Extra (newLock, withLock)-import Control.Monad.Extra (unless, when, whenJust)-import qualified Data.Aeson.Encode.Pretty as A+import Control.Monad.Extra (unless, whenJust) import Data.Default (Default (def))-import Data.List.Extra (upper)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.Text.Lazy.Encoding (decodeUtf8)-import qualified Data.Text.Lazy.IO as LT import Data.Version (showVersion) import Development.GitRev (gitHash)-import Development.IDE (Logger (Logger),- Priority (Info), action)+import Development.IDE (action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import Development.IDE.Graph (ShakeOptions (shakeThreads))@@ -28,8 +20,6 @@ import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject))-import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,- pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) import qualified System.Directory.Extra as IO@@ -51,35 +41,18 @@ main :: IO () main = do+ let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work- Arguments{..} <- getArguments+ Arguments{..} <- getArguments hlsPlugins if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors-- when argsVSCodeExtensionSchema $ do- LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema hlsPlugins- exitSuccess-- when argsDefaultConfig $ do- LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins- exitSuccess- whenJust argsCwd IO.setCurrentDirectory - -- lock to avoid overlapping output on stdout- lock <- newLock- let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $- T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg- logLevel = if argsVerbose then minBound else Info- Main.defaultMain def {Main.argCommand = argsCommand-- ,Main.argsLogger = pure logger ,Main.argsRules = do -- install the main and ghcide-plugin rules
ghcide.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-version: 1.4.0.3+version: 1.4.1.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors@@ -34,6 +34,7 @@ default-language: Haskell2010 build-depends: aeson,+ aeson-pretty, array, async, base == 4.*,@@ -47,7 +48,8 @@ dependent-map, dependent-sum, dlist,- extra >= 1.7.4,+ -- we can't use >= 1.7.10 while we have to use hlint == 3.2.*+ extra >= 1.7.4 && < 1.7.10, fuzzy, filepath, fingertree,@@ -57,10 +59,10 @@ haddock-library >= 1.8 && < 1.11, hashable, hie-compat ^>= 0.2.0.0,- hls-plugin-api ^>= 1.1.0.0,+ hls-plugin-api ^>= 1.2.0.0, lens, hiedb == 0.4.0.*,- lsp-types >= 1.2 && < 1.4,+ lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, mtl, network-uri,@@ -97,10 +99,9 @@ ghc >= 8.6, ghc-check >=0.5.0.4, ghc-paths,- ghc-api-compat, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios >= 0.7.1 && < 0.8.0,- implicit-hie-cradle >= 0.3.0.2 && < 0.4,+ implicit-hie-cradle >= 0.3.0.5 && < 0.4, base16-bytestring >=0.1.1 && <1.1 if os(windows) build-depends:@@ -109,6 +110,22 @@ build-depends: unix + if impl(ghc < 8.10.5)+ build-depends:+ ghc-api-compat ==8.6+ elif impl(ghc == 8.10.5)+ build-depends:+ ghc-api-compat ==8.10.5+ elif impl(ghc == 8.10.6)+ build-depends:+ ghc-api-compat ==8.10.6+ elif impl(ghc == 8.10.7)+ build-depends:+ ghc-api-compat ==8.10.7+ elif impl(ghc == 9.0.1)+ build-depends:+ ghc-api-compat ==9.0.1+ default-extensions: ApplicativeDo BangPatterns@@ -286,7 +303,6 @@ hls-graph, text, unordered-containers,- aeson-pretty other-modules: Arguments Paths_ghcide@@ -370,6 +386,7 @@ main-is: Main.hs other-modules: Development.IDE.Test+ Development.IDE.Test.Diagnostic Development.IDE.Test.Runfiles Experiments Experiments.Types@@ -403,17 +420,20 @@ extra, filepath, ghcide,+ lens, lsp-test,+ lsp-types, optparse-applicative, process, safe-exceptions, hls-graph, shake, text- hs-source-dirs: bench/lib bench/exe+ hs-source-dirs: bench/lib bench/exe test/src ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts main-is: Main.hs other-modules:+ Development.IDE.Test.Diagnostic Experiments Experiments.Types default-extensions:
session-loader/Development/IDE/Session.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-|@@ -86,7 +85,6 @@ import HieDb.Create import HieDb.Types import HieDb.Utils-import Ide.Types (dynFlagsModifyGlobal) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String@@ -197,7 +195,7 @@ getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do- let db = intercalate "-" [dirHash, takeBaseName dir, VERSION_ghc, hiedbDataVersion] <.> "hiedb"+ let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir@@ -284,8 +282,7 @@ packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir- (df, targets) <- evalGhcEnv hscEnv $- first (dynFlagsModifyGlobal optModifyDynFlags) <$> setOptions opts (hsc_dflags hscEnv)+ (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv@@ -526,11 +523,10 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession-#if !MIN_VERSION_ghc(9,0,0)- -- This causes ghc9 to crash with the error:- -- Couldn't find a target code interpreter. Try with -fexternal-interpreter- initDynLinker env-#endif+ when (ghcVersion < GHC90) $+ -- This causes ghc9 to crash with the error:+ -- Couldn't find a target code interpreter. Try with -fexternal-interpreter+ initDynLinker env pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails
src/Development/IDE.hs view
@@ -42,6 +42,8 @@ useWithStaleFast', useWithStale_, use_, uses, uses_)+import Development.IDE.GHC.Compat as X (GhcVersion (..),+ ghcVersion) import Development.IDE.GHC.Error as X import Development.IDE.GHC.Util as X import Development.IDE.Graph as X (Action, RuleResult,
src/Development/IDE/Core/Actions.hs view
@@ -30,8 +30,10 @@ writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint+import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb+import HscTypes (hsc_dflags) import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) @@ -62,10 +64,11 @@ opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file- dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)+ df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file+ dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)- MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos'+ MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos' toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go
src/Development/IDE/Core/Compile.hs view
@@ -974,7 +974,7 @@ Just (LM obj_time _ _) -> obj_time > ms_hs_date ms if objUpToDate then do- hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface{mi_globals=Nothing} linkable+ hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable return ([], Just $ mkHiFileResult ms hmi) else regen linkableNeeded (_reason, _) -> regen linkableNeeded
src/Development/IDE/Core/PositionMapping.hs view
@@ -30,7 +30,8 @@ import Data.List import qualified Data.Text as T import qualified Data.Vector.Unboxed as V-import Language.LSP.Types+import Language.LSP.Types (Position (Position), Range (Range),+ TextDocumentContentChangeEvent (TextDocumentContentChangeEvent)) -- | Either an exact position, or the range of text that was substituted data PositionResult a
src/Development/IDE/Core/Rules.hs view
@@ -151,6 +151,7 @@ import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId)+import qualified Data.HashSet as HS -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing@@ -291,7 +292,10 @@ liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a-getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions+getModifyDynFlags f = do+ opts <- getIdeOptions+ cfg <- getClientConfigAction def+ pure $ f $ optModifyDynFlags opts cfg getParsedModuleDefinition@@ -311,6 +315,7 @@ define $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets+ let targetsMap = HM.mapWithKey const targets let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env_eq <- use_ GhcSession file let env = hscEnvWithImportPaths env_eq@@ -321,14 +326,24 @@ then addRelativeImport file (moduleName $ ms_mod ms) dflags else dflags opt <- getIdeOptions- let getTargetExists modName nfp- | isImplicitCradle = getFileExists nfp- | HM.member (TargetModule modName) targets- || HM.member (TargetFile nfp) targets- = getFileExists nfp- | otherwise = return False+ let getTargetFor modName nfp+ | isImplicitCradle = do+ itExists <- getFileExists nfp+ return $ if itExists then Just nfp else Nothing+ | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do+ -- reuse the existing NormalizedFilePath in order to maximize sharing+ itExists <- getFileExists nfp'+ return $ if itExists then Just nfp' else Nothing+ | Just tt <- HM.lookup (TargetModule modName) targets = do+ -- reuse the existing NormalizedFilePath in order to maximize sharing+ let ttmap = HM.mapWithKey const (HS.toMap tt)+ nfp' = HM.lookupDefault nfp nfp ttmap+ itExists <- getFileExists nfp'+ return $ if itExists then Just nfp' else Nothing+ | otherwise+ = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do- diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path))
src/Development/IDE/GHC/Compat.hs view
@@ -14,7 +14,6 @@ HieFile(..), NameCacheUpdater(..), hieExportNames,- mkHieFile, mkHieFile', enrichHie, writeHieFile,@@ -115,6 +114,7 @@ getNodeIds, stringToUnit, rtsUnit,+ unitString, LogActionCompat, logActionCompat,@@ -127,8 +127,12 @@ applyPluginsParsedResultAction, module Compat.HieTypes, module Compat.HieUtils,- dropForAll- ,isQualifiedImport) where+ dropForAll,+ isQualifiedImport,+ GhcVersion(..),+ ghcVersion,+ ghcVersionStr+ ) where #if MIN_VERSION_ghc(8,10,0) import LinkerTypes@@ -148,6 +152,7 @@ import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load import GHC.Types.Unique.Set (emptyUniqSet)+import Module (unitString) import qualified SrcLoc #else import Module (InstalledUnitId,@@ -155,7 +160,7 @@ toInstalledUnitId) import TcType (pprSigmaType) #endif-import Compat.HieAst (enrichHie, mkHieFile)+import Compat.HieAst (enrichHie) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils@@ -524,7 +529,7 @@ #endif pattern FunTy :: Type -> Type -> Type-#if MIN_VERSION_ghc(8, 10, 0)+#if MIN_VERSION_ghc(8,10,0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} #else pattern FunTy arg res <- TyCoRep.FunTy arg res@@ -541,7 +546,7 @@ -#if __GLASGOW_HASKELL__ >= 900+#if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -575,8 +580,8 @@ nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId--- unitString :: Unit -> String--- unitString = unitIdString+unitString :: Unit -> String+unitString = Module.unitIdString stringToUnit :: String -> Unit stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit@@ -586,6 +591,23 @@ rtsUnit = Module.rtsUnitId #endif -#if MIN_VERSION_ghc(9,0,0)-#else+data GhcVersion+ = GHC86+ | GHC88+ | GHC810+ | GHC90+ deriving (Eq, Ord, Show)++ghcVersionStr :: String+ghcVersionStr = VERSION_ghc++ghcVersion :: GhcVersion+#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+ghcVersion = GHC90+#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)+ghcVersion = GHC810+#elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)+ghcVersion = GHC88+#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)+ghcVersion = GHC86 #endif
src/Development/IDE/GHC/ExactPrint.hs view
@@ -338,7 +338,7 @@ -- | The type of nodes we'd like to consider when finding the smallest. Proxy (Located ast) -> SrcSpan ->- (DynFlags -> GenericM (TransformT m)) ->+ (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithSmallestM proxy dst trans = Graft $ \dflags -> smallestM (genericIsSubspan proxy dst) (trans dflags)@@ -351,7 +351,7 @@ -- | The type of nodes we'd like to consider when finding the largest. Proxy (Located ast) -> SrcSpan ->- (DynFlags -> GenericM (TransformT m)) ->+ (DynFlags -> ast -> GenericM (TransformT m)) -> Graft m a genericGraftWithLargestM proxy dst trans = Graft $ \dflags -> largestM (genericIsSubspan proxy dst) (trans dflags)
src/Development/IDE/GHC/Orphans.hs view
@@ -21,6 +21,7 @@ import GhcPlugins import Retrie.ExactPrint (Annotated) import qualified StringBuffer as SB+import Unique (getKey) -- Orphan instances for types from the GHC API.@@ -50,6 +51,8 @@ hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else instance Show InstalledUnitId where show = prettyPrint+deriving instance Ord SrcSpan+deriving instance Ord UnhelpfulSpanReason #endif instance NFData SB.StringBuffer where rnf = rwhnf@@ -162,3 +165,6 @@ instance (NFData (HsModule a)) where #endif rnf = rwhnf++instance Show OccName where show = prettyPrint+instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)
src/Development/IDE/Import/FindImports.hs view
@@ -69,15 +69,15 @@ locateModuleFile :: MonadIO m => [[FilePath]] -> [String]- -> (ModuleName -> NormalizedFilePath -> m Bool)+ -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName -> m (Maybe NormalizedFilePath)-locateModuleFile import_dirss exts doesExist isSource modName = do+locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts]- findM (doesExist modName) (concatMap candidates import_dirss)+ firstJustM (targetFor modName) (concatMap candidates import_dirss) where maybeBoot ext | isSource = ext ++ "-boot"@@ -97,12 +97,12 @@ => DynFlags -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions- -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate+ -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> Maybe FastString -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import)-locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do+locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do@@ -118,7 +118,7 @@ -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure.- mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName case mbFile of Nothing -> lookupInPackageDB dflags Just file -> toModLocation file@@ -129,7 +129,7 @@ return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) lookupLocal dirs = do- mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName+ mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] Just file -> toModLocation file
src/Development/IDE/LSP/Outline.hs view
@@ -22,7 +22,13 @@ realSrcSpanToRange) import Development.IDE.Types.Location import Language.LSP.Server (LspM)-import Language.LSP.Types+import Language.LSP.Types (DocumentSymbol (..),+ DocumentSymbolParams (DocumentSymbolParams, _textDocument),+ List (..), ResponseError,+ SymbolInformation,+ SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown),+ TextDocumentIdentifier (TextDocumentIdentifier),+ type (|?) (InL), uriToFilePath) import Outputable (Outputable, ppr, showSDocUnsafe)
src/Development/IDE/Main.hs view
@@ -13,6 +13,7 @@ catchAny) import Control.Monad.Extra (concatMapM, unless, when)+import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) import Data.Foldable (traverse_) import qualified Data.HashMap.Strict as HashMap@@ -22,7 +23,10 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import qualified Data.Text.IO as T-import Development.IDE (Action, Rules,+import Data.Text.Lazy.Encoding (decodeUtf8)+import qualified Data.Text.Lazy.IO as LT+import Development.IDE (Action, GhcVersion (..),+ Rules, ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer)@@ -71,10 +75,16 @@ import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification)+import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,+ pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)-import Ide.Types (IdePlugins)+import Ide.Types (IdeCommand (IdeCommand),+ IdePlugins,+ PluginDescriptor (PluginDescriptor, pluginCli),+ PluginId (PluginId),+ ipMap) import qualified Language.LSP.Server as LSP import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO@@ -97,13 +107,12 @@ | Db {projectRoot :: FilePath, hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server- | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand} -- ^ User defined+ | PrintExtensionSchema+ | PrintDefaultConfig+ | Custom {projectRoot :: FilePath, ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show -newtype IdeCommand = IdeCommand (IdeState -> IO ()) -instance Show IdeCommand where show _ = "<ide command>"- -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options@@ -112,18 +121,33 @@ isLSP LSP = True isLSP _ = False -commandP :: Parser Command-commandP = hsubparser (command "typecheck" (info (Check <$> fileCmd) fileInfo)- <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)- <> command "lsp" (info (pure LSP <**> helper) lspInfo)- )+commandP :: IdePlugins IdeState -> Parser Command+commandP plugins =+ hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo)+ <> command "hiedb" (info (Db "." <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo)+ <> command "lsp" (info (pure LSP <**> helper) lspInfo)+ <> command "vscode-extension-schema" extensionSchemaCommand+ <> command "generate-default-config" generateDefaultConfigCommand+ <> pluginCommands+ ) where fileCmd = many (argument str (metavar "FILES/DIRS...")) lspInfo = fullDesc <> progDesc "Start talking to an LSP client" fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" hieInfo = fullDesc <> progDesc "Query .hie files"+ extensionSchemaCommand =+ info (pure PrintExtensionSchema)+ (fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")+ generateDefaultConfigCommand =+ info (pure PrintDefaultConfig)+ (fullDesc <> progDesc "Print config supported by the server with default values") + pluginCommands = mconcat+ [ command (T.unpack pId) (Custom "." <$> p)+ | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins+ ] + data Arguments = Arguments { argsOTMemoryProfiling :: Bool , argCommand :: Command@@ -198,6 +222,10 @@ outH <- argsHandleOut case argCommand of+ PrintExtensionSchema ->+ LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins+ PrintDefaultConfig ->+ LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..."@@ -229,6 +257,11 @@ , optRunSubset = runSubset } caps = LSP.resClientCapabilities env+ -- FIXME: Remove this after GHC 9 gets fully supported+ when (ghcVersion == GHC90) $+ hPutStrLn stderr $+ "Currently, HLS supports GHC 9 only partially. "+ <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." initialise argsDefaultHlsConfig rules@@ -310,6 +343,7 @@ case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd+ Custom projectRoot (IdeCommand c) -> do dbLoc <- getHieDbLoc projectRoot runWithDb dbLoc $ \hiedb hieChan -> do
src/Development/IDE/Plugin.hs view
@@ -10,7 +10,7 @@ data Plugin c = Plugin {pluginRules :: Rules () ,pluginHandlers :: LSP.Handlers (ServerM c)- ,pluginModifyDynflags :: DynFlagsModifications+ ,pluginModifyDynflags :: c -> DynFlagsModifications } instance Default (Plugin c) where
src/Development/IDE/Plugin/CodeAction.hs view
@@ -11,7 +11,9 @@ iePluginDescriptor, typeSigsPluginDescriptor, bindingsPluginDescriptor,- fillHolePluginDescriptor+ fillHolePluginDescriptor,+ newImport,+ newImportToEdit -- * For testing , matchRegExMultipleImports ) where@@ -60,7 +62,20 @@ import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP-import Language.LSP.Types+import Language.LSP.Types (CodeAction (..),+ CodeActionContext (CodeActionContext, _diagnostics),+ CodeActionKind (CodeActionQuickFix, CodeActionUnknown),+ CodeActionParams (CodeActionParams),+ Command,+ Diagnostic (..),+ List (..),+ ResponseError,+ SMethod (STextDocumentCodeAction),+ TextDocumentIdentifier (TextDocumentIdentifier),+ TextEdit (TextEdit),+ WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),+ type (|?) (InR),+ uriToFilePath) import Language.LSP.VFS import Module (moduleEnvElts) import OccName@@ -835,7 +850,7 @@ -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo- { name = binding+ { name = mkVarOcc $ T.unpack binding , rendered = binding , parent = Nothing , isDatacon = False
src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs view
@@ -12,7 +12,8 @@ import Data.Char import Data.List-import Language.LSP.Types+import Language.LSP.Types (Position (Position),+ Range (Range, _end, _start)) type PositionIndexed a = [(Position, a)]
src/Development/IDE/Plugin/Completions.hs view
@@ -13,6 +13,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set import Data.List (find) import Data.Maybe import qualified Data.Text as T@@ -23,16 +25,21 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint (Annotated (annsA),- GetAnnotatedParsedSource (GetAnnotatedParsedSource))+ GetAnnotatedParsedSource (GetAnnotatedParsedSource),+ astA) import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes+import Development.IDE.Plugin.CodeAction (newImport,+ newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types-import Development.IDE.Types.HscEnvEq (hscEnv)+import Development.IDE.Types.Exports+import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports),+ hscEnv) import Development.IDE.Types.Location-import GHC.Exts (toList)+import GHC.Exts (fromList, toList) import GHC.Generics import Ide.Plugin.Config (Config) import Ide.Types@@ -130,7 +137,12 @@ nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath- pure (opts, fmap (,pm,binds) ((fst <$> localCompls) <> (fst <$> nonLocalCompls)))+ exportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath+ exportsMap <- mapM liftIO exportsMapIO+ let exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap <$> exportsMap+ exportsCompls = mempty{anyQualCompls = fromMaybe [] exportsCompItems}+ let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls+ pure (opts, fmap (,pm,binds) compls) case compls of Just (cci', parsedMod, bindMap) -> do pfix <- VFS.getCompletionPrefix position cnts@@ -185,10 +197,20 @@ let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual- imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) msrImports- fmap (nfp,) $ liftEither $- rewriteToWEdit df doc (annsA ps) $- extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp+ existingImport = find (isWantedModule wantedModule wantedQual) msrImports+ case existingImport of+ Just imp -> do+ fmap (nfp,) $ liftEither $+ rewriteToWEdit df doc (annsA ps) $+ extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp+ Nothing -> do+ let n = newImport importName sym importQual False+ sym = if isNothing importQual then Just it else Nothing+ it = case thingParent of+ Nothing -> newThing+ Just p -> p <> "(" <> newThing <> ")"+ t <- liftMaybe $ snd <$> newImportToEdit n (astA ps)+ return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -9,6 +9,7 @@ , cacheDataProducer , localCompletionsForParsedModule , getCompletions+, fromIdentInfo ) where import Control.Applicative@@ -19,6 +20,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust,+ isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T@@ -49,6 +51,7 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings+import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options import GhcPlugins (flLabel, unpackFS)@@ -302,6 +305,25 @@ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing Nothing +fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem+fromIdentInfo doc IdentInfo{..} q = CI+ { compKind= occNameToComKind Nothing name+ , insertText=rendered+ , importedFrom=Right moduleNameText+ , typeText=Nothing+ , label=rendered+ , isInfix=Nothing+ , docs=emptySpanDoc+ , isTypeCompl= not isDatacon && isUpper (T.head rendered)+ , additionalTextEdits= Just $+ ExtendImport+ { doc,+ thingParent = parent,+ importName = moduleNameText,+ importQual = q,+ newThing = rendered+ }+ } cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do@@ -385,6 +407,7 @@ { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals+ , anyQualCompls = [] , importableModules = moduleNames } @@ -394,6 +417,7 @@ CC { allModNamesAsNS = mempty , unqualCompls = compls , qualCompls = mempty+ , anyQualCompls = [] , importableModules = mempty } where@@ -507,7 +531,7 @@ -> ClientCapabilities -> CompletionsConfig -> IO [CompletionItem]-getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, importableModules}+getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} maybe_parsed (localBindings, bmapping) prefixInfo caps config = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "."@@ -566,8 +590,9 @@ Just m -> Right $ ppr m compls = if T.null prefixModule- then localCompls ++ unqualCompls- else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls+ then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls)+ else Map.findWithDefault [] prefixModule (getQualCompls qualCompls)+ ++ (($ Just prefixModule) <$> anyQualCompls) filtListWith f list = [ f label@@ -606,13 +631,26 @@ | "{-# " `T.isPrefixOf` fullLine -> return $ filtPragmaCompls (pragmaSuffix fullLine) | otherwise -> do- let uniqueFiltCompls = nubOrdOn insertText filtCompls+ -- assumes that nubOrdBy is stable+ let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls return $ filtModNameCompls ++ filtKeywordCompls ++ map (toggleSnippets caps config) compls -+uniqueCompl :: CompItem -> CompItem -> Ordering+uniqueCompl x y =+ case compare (label x, importedFrom x, compKind x)+ (label y, importedFrom y, compKind y) of+ EQ ->+ -- preserve completions for duplicate record fields where the only difference is in the type+ -- remove redundant completions with less type info+ if typeText x == typeText y+ || isNothing (typeText x)+ || isNothing (typeText y)+ then EQ+ else compare (insertText x) (insertText y)+ other -> other -- --------------------------------------------------------------------- -- helper functions for pragmas -- ---------------------------------------------------------------------
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -20,7 +20,7 @@ import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp)-import Language.LSP.Types (CompletionItemKind, Uri)+import Language.LSP.Types (CompletionItemKind (..), Uri) -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -91,18 +91,21 @@ data CachedCompletions = CC { allModNamesAsNS :: [T.Text] -- ^ All module names in scope. -- Prelude is a single module- , unqualCompls :: [CompItem] -- ^ All Possible completion items+ , unqualCompls :: [CompItem] -- ^ Unqualified completion items , qualCompls :: QualCompls -- ^ Completion items associated to -- to a specific module name.+ , anyQualCompls :: [Maybe T.Text -> CompItem] -- ^ Items associated to any qualifier , importableModules :: [T.Text] -- ^ All modules that may be imported.- } deriving Show+ } +instance Show CachedCompletions where show _ = "<cached completions>"+ instance NFData CachedCompletions where rnf = rwhnf instance Monoid CachedCompletions where- mempty = CC mempty mempty mempty mempty+ mempty = CC mempty mempty mempty mempty mempty instance Semigroup CachedCompletions where- CC a b c d <> CC a' b' c' d' =- CC (a<>a') (b<>b') (c<>c') (d<>d')+ CC a b c d e <> CC a' b' c' d' e' =+ CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e')
src/Development/IDE/Plugin/HLS.hs view
@@ -70,7 +70,14 @@ rules = foldMap snd rs dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config-dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = foldMap snd rs }+dynFlagsPlugins rs = mempty+ { P.pluginModifyDynflags =+ flip foldMap rs $ \(plId, dflag_mods) cfg ->+ let plg_cfg = configForPlugin cfg plId+ in if plcGlobalOn plg_cfg+ then dflag_mods+ else mempty+ } -- ---------------------------------------------------------------------
src/Development/IDE/Spans/AtPoint.hs view
@@ -56,6 +56,7 @@ import Data.List (isSuffixOf) import Data.List.Extra (dropEnd1, nubOrd) +import Data.Version (showVersion) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) @@ -196,15 +197,16 @@ :: IdeOptions -> HieAstResult -> DocAndKindMap+ -> DynFlags -> Position -> Maybe (Maybe Range, [T.Text])-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo+atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) where pTypes- | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes+ | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes | otherwise = map wrapHaskell prettyTypes range = realSrcSpanToRange $ nodeSpan ast@@ -219,10 +221,19 @@ prettyName (Right n, dets) = T.unlines $ wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : definedAt n+ ++ maybeToList (prettyPackageName n) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n ] where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n prettyName (Left m,_) = showGhc m++ prettyPackageName n = do+ m <- nameModule_maybe n+ let pid = moduleUnitId m+ conf <- lookupPackage df pid+ let pkgName = T.pack $ packageNameString conf+ version = T.pack $ showVersion (packageVersion conf)+ pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of
src/Development/IDE/Types/Exports.hs view
@@ -9,24 +9,26 @@ createExportsMapTc ,createExportsMapHieDb,size) where -import Avail (AvailInfo (..))-import Control.DeepSeq (NFData (..))+import Avail (AvailInfo (..))+import Control.DeepSeq (NFData (..)) import Control.Monad-import Data.Bifunctor (Bifunctor (second))-import Data.HashMap.Strict (HashMap, elems)-import qualified Data.HashMap.Strict as Map-import Data.HashSet (HashSet)-import qualified Data.HashSet as Set-import Data.Hashable (Hashable)-import Data.Text (Text, pack)+import Data.Bifunctor (Bifunctor (second))+import Data.HashMap.Strict (HashMap, elems)+import qualified Data.HashMap.Strict as Map+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Hashable (Hashable)+import Data.List (isSuffixOf)+import Data.Text (Text, pack) import Development.IDE.GHC.Compat+import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util-import FieldLabel (flSelector)-import GHC.Generics (Generic)-import GhcPlugins (IfaceExport, ModGuts (..))+import FieldLabel (flSelector)+import GHC.Generics (Generic)+import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb import Name-import TcRnTypes (TcGblEnv (..))+import TcRnTypes (TcGblEnv (..)) newtype ExportsMap = ExportsMap {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)}@@ -41,7 +43,7 @@ type IdentifierText = Text data IdentInfo = IdentInfo- { name :: !Text+ { name :: !OccName , rendered :: Text , parent :: !(Maybe Text) , isDatacon :: !Bool@@ -72,19 +74,19 @@ mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] mkIdentInfos mod (Avail n) =- [IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]+ [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent- = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod+ = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod | n <- nn ++ map flSelector flds ] ++- [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]+ [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] where parentP = pack $ printName parent mkIdentInfos mod (AvailTC _ nn flds)- = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod+ = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod | n <- nn ++ map flSelector flds ] @@ -109,23 +111,29 @@ where mn = moduleName $ tcg_mod mi +nonInternalModules :: ModuleName -> Bool+nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString+ createExportsMapHieDb :: HieDb -> IO ExportsMap createExportsMapHieDb hiedb = do mods <- getAllIndexedMods hiedb- idents <- forM mods $ \m -> do+ idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m mText = pack $ moduleNameString mn fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn return $ ExportsMap $ Map.fromListWith (<>) (concat idents) where- wrap identInfo = (name identInfo, Set.fromList [identInfo])+ wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) -- unwrap :: ExportRow -> IdentInfo- unwrap m ExportRow{..} = IdentInfo n n p exportIsDatacon m+ unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m where n = pack (occNameString exportName) p = pack . occNameString <$> exportParent unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])]-unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod+unpackAvail mn+ | nonInternalModules mn = map f . mkIdentInfos mod+ | otherwise = const [] where- f id@IdentInfo {..} = (name, [id])+ !mod = pack $ moduleNameString mn+ f id@IdentInfo {..} = (pack (prettyPrint name), [id])
src/Development/IDE/Types/Options.hs view
@@ -72,7 +72,7 @@ -- Otherwise, return the result of parsing without Opt_Haddock, so -- that the parsed module contains the result of Opt_KeepRawTokenStream, -- which might be necessary for hlint.- , optModifyDynFlags :: DynFlagsModifications+ , optModifyDynFlags :: Config -> DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used , optShakeOptions :: ShakeOptions
src/Generics/SYB/GHC.hs view
@@ -29,9 +29,9 @@ -- | The type of nodes we'd like to consider. Proxy (Located ast) -> SrcSpan ->- GenericQ (Maybe Bool)+ GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case- (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span+ (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) -- | Lift a function that replaces a value with several values into a generic@@ -70,19 +70,19 @@ -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used.-smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m+smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m smallestM q f = fmap snd . go where go :: GenericMQ Any m go x = do case q x of Nothing -> gmapMQ go x- Just True -> do+ Just (True, a) -> do it@(r, x') <- gmapMQ go x case r of Any True -> pure it- Any False -> fmap (Any True,) $ f x'- Just False -> pure (mempty, x)+ Any False -> fmap (Any True,) $ f a x'+ Just (False, _) -> pure (mempty, x) ------------------------------------------------------------------------------ -- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but@@ -94,14 +94,14 @@ -- with data nodes, so for any given node we can only definitely return an -- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is -- used.-largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m+largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m largestM q f = go where go :: GenericM m go x = do case q x of- Just True -> f x- Just False -> pure x+ Just (True, a) -> f a x+ Just (False, _) -> pure x Nothing -> gmapM go x newtype MonadicQuery r m a = MonadicQuery
− test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_a (- version,- getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,- getDataFileName, getSysconfDir- ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [0,1,0,0] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir = "/Users/pepeiborra/.cabal/bin"-libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a"-dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3"-datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0"-libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0"-sysconfdir = "/Users/pepeiborra/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do- dir <- getDataDir- return (dir ++ "/" ++ name)
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_a (- version,- getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,- getDataFileName, getSysconfDir- ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [1,0,0] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir = "/Users/pepeiborra/.cabal/bin"-libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace"-dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2"-datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0"-libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0"-sysconfdir = "/Users/pepeiborra/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do- dir <- getDataDir- return (dir ++ "/" ++ name)
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_a (- version,- getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,- getDataFileName, getSysconfDir- ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [1,0,0] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir = "/Users/pepeiborra/.cabal/bin"-libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace"-dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3"-datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0"-libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0"-sysconfdir = "/Users/pepeiborra/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do- dir <- getDataDir- return (dir ++ "/" ++ name)
− test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoRebindableSyntax #-}-{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}-module Paths_b (- version,- getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,- getDataFileName, getSysconfDir- ) where--import qualified Control.Exception as Exception-import Data.Version (Version(..))-import System.Environment (getEnv)-import Prelude--#if defined(VERSION_base)--#if MIN_VERSION_base(4,0,0)-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#else-catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a-#endif--#else-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#endif-catchIO = Exception.catch--version :: Version-version = Version [1,0,0] []-bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath--bindir = "/Users/pepeiborra/.cabal/bin"-libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace"-dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3"-datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0"-libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0"-sysconfdir = "/Users/pepeiborra/.cabal/etc"--getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath-getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir)-getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir)-getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir)-getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir)-getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir)-getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir)--getDataFileName :: FilePath -> IO FilePath-getDataFileName name = do- dir <- getDataDir- return (dir ++ "/" ++ name)
test/exe/Main.hs view
@@ -35,6 +35,8 @@ positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..))+import Development.IDE.GHC.Compat (GhcVersion (..),+ ghcVersion) import Development.IDE.GHC.Util import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.Completions.Types (extendImportCommandId)@@ -58,7 +60,10 @@ import qualified Experiments as Bench import Ide.Plugin.Config import Language.LSP.Test-import Language.LSP.Types hiding (mkRange)+import Language.LSP.Types hiding+ (mkRange, SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as Lsp (diagnostics, message,@@ -538,17 +543,15 @@ , "foo = 1 {-|-}" ] _ <- createDoc "Foo.hs" "haskell" fooContent-#if MIN_VERSION_ghc(9,0,1)- -- Haddock parse errors are ignored on ghc-9.0.1- pure ()-#else- expectDiagnostics- [ ( "Foo.hs"- , [(DsWarning, (2, 8), "Haddock parse error on input")+ if ghcVersion >= GHC90 then+ -- Haddock parse errors are ignored on ghc-9.0.1+ pure ()+ else+ expectDiagnostics+ [ ( "Foo.hs"+ , [(DsWarning, (2, 8), "Haddock parse error on input")]+ ) ]- )- ]-#endif , testSessionWait "strip file path" $ do let name = "Testing"@@ -3591,17 +3594,17 @@ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] dcL12 = Position 16 11 ;- xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types"]]+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] opL16 = Position 20 15 ; op = [mkR 21 2 21 4] opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]- xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]]+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] clL25 = Position 29 9- eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num"]]+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] dnbL30 = Position 34 23 lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]@@ -3629,12 +3632,11 @@ mkFindTests -- def hover look expect [-#if MIN_VERSION_ghc(9,0,0)- -- It suggests either going to the constructor or to the field- test broken yes fffL4 fff "field in record definition"-#else- test yes yes fffL4 fff "field in record definition"-#endif+ if ghcVersion >= GHC90 then+ -- It suggests either going to the constructor or to the field+ test broken yes fffL4 fff "field in record definition"+ else+ test yes yes fffL4 fff "field in record definition" , test yes yes fffL8 fff "field in record construction #1102" , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120@@ -3657,11 +3659,10 @@ , test yes yes lclL33 lcb "listcomp lookup" , test yes yes mclL36 mcl "top-level fn 1st clause" , test yes yes mclL37 mcl "top-level fn 2nd clause #1030"-#if MIN_VERSION_ghc(8,10,0)- , test yes yes spaceL37 space "top-level fn on space #1002"-#else- , test yes broken spaceL37 space "top-level fn on space #1002"-#endif+ , if ghcVersion >= GHC810 then+ test yes yes spaceL37 space "top-level fn on space #1002"+ else+ test yes broken spaceL37 space "top-level fn on space #1002" , test no yes docL41 doc "documentation #1129" , test no yes eitL40 kindE "kind of Either #1017" , test no yes intL40 kindI "kind of Int #1017"@@ -3670,18 +3671,20 @@ , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016"-#if MIN_VERSION_ghc(9,0,0)- , test no yes docL41 constr "type constraint in hover info #1012"-#else- , test no broken docL41 constr "type constraint in hover info #1012"-#endif+ , if ghcVersion >= GHC90 then+ test no yes docL41 constr "type constraint in hover info #1012"+ else+ test no broken docL41 constr "type constraint in hover info #1012" , test broken broken outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" , test no skip cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)"- , test no yes thLocL57 thLoc "TH Splice Hover"+ , if ghcVersion == GHC90 && isWindows then+ test no broken thLocL57 thLoc "TH Splice Hover"+ else+ test no yes thLocL57 thLoc "TH Splice Hover" ] where yes, broken :: (TestTree -> Maybe TestTree) yes = Just -- test should run and pass@@ -3699,7 +3702,7 @@ pluginSimpleTests = ignoreInWindowsForGHC88And810 $ #if __GLASGOW_HASKELL__ == 810 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 5- expectFailBecause "known broken (see GHC #19763)" $+ expectFailBecause "known broken for ghc 8.10.5 (see GHC #19763)" $ #endif testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir </> "KnownNat.hs") "haskell"@@ -3968,6 +3971,7 @@ [ testGroup "non local" nonLocalCompletionTests , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests+ , testGroup "global" globalCompletionTests , testGroup "other" otherCompletionTests ] @@ -3979,8 +3983,9 @@ let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] liftIO $ do let emptyToMaybe x = if T.null x then Nothing else Just x- sortOn (Lens.view Lens._1) compls' @?=- sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected]+ sortOn (Lens.view Lens._1) (take (length expected) compls') @?=+ sortOn (Lens.view Lens._1)+ [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do when expectedSig $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)@@ -4362,7 +4367,7 @@ _ <- waitForDiagnostics compls <- getCompletions docA $ Position 2 4 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]- liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"],+ liftIO $ take 2 compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines@@ -4375,6 +4380,105 @@ liftIO $ length compls @?= maxCompletions def ] +globalCompletionTests :: [TestTree]+globalCompletionTests =+ [ testSessionWait "fromList" $ do+ doc <- createDoc "A.hs" "haskell" $ T.unlines+ [ "{-# OPTIONS_GHC -Wunused-binds #-}",+ "module A () where",+ "a = fromList"+ ]+ _ <- waitForDiagnostics+ compls <- getCompletions doc (Position 2 12)+ let compls' =+ [T.drop 1 $ T.dropEnd 10 d+ | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+ <- compls+ , _label == "fromList"+ ]+ liftIO $ take 3 (sort compls') @?=+ map ("Defined in "<>)+ [ "'Data.IntMap"+ , "'Data.IntMap.Lazy"+ , "'Data.IntMap.Strict"+ ]++ , testSessionWait "Map" $ do+ doc <- createDoc "A.hs" "haskell" $ T.unlines+ [ "{-# OPTIONS_GHC -Wunused-binds #-}",+ "module A () where",+ "a :: Map"+ ]+ _ <- waitForDiagnostics+ compls <- getCompletions doc (Position 2 7)+ let compls' =+ [T.drop 1 $ T.dropEnd 10 d+ | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+ <- compls+ , _label == "Map"+ ]+ liftIO $ take 3 (sort compls') @?=+ map ("Defined in "<>)+ [ "'Data.Map"+ , "'Data.Map.Lazy"+ , "'Data.Map.Strict"+ ]+ , testSessionWait "no duplicates" $ do+ doc <- createDoc "A.hs" "haskell" $ T.unlines+ [ "{-# OPTIONS_GHC -Wunused-binds #-}",+ "module A () where",+ "import GHC.Exts(fromList)",+ "a = fromList"+ ]+ _ <- waitForDiagnostics+ compls <- getCompletions doc (Position 3 13)+ let duplicate =+ find+ (\case+ CompletionItem+ { _insertText = Just "fromList"+ , _documentation =+ Just (CompletionDocMarkup (MarkupContent MkMarkdown d))+ } ->+ "GHC.Exts" `T.isInfixOf` d+ _ -> False+ ) compls+ liftIO $ duplicate @?= Nothing++ , testSessionWait "non-local before global" $ do+ -- non local completions are more specific+ doc <- createDoc "A.hs" "haskell" $ T.unlines+ [ "{-# OPTIONS_GHC -Wunused-binds #-}",+ "module A () where",+ "import GHC.Exts(fromList)",+ "a = fromList"+ ]+ _ <- waitForDiagnostics+ compls <- getCompletions doc (Position 3 13)+ let compls' =+ [_insertText+ | CompletionItem {_label, _insertText} <- compls+ , _label == "fromList"+ ]+ liftIO $ take 3 compls' @?=+ map Just ["fromList ${1:([Item l])}", "fromList", "fromList"]+ , testGroup "auto import snippets"+ [ completionCommandTest+ "import Data.Sequence"+ ["module A where", "foo :: Seq"]+ (Position 1 9)+ "Seq"+ ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"]++ , completionCommandTest+ "qualified import"+ ["module A where", "foo :: Seq.Seq"]+ (Position 1 13)+ "Seq"+ ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"]+ ]+ ]+ highlightTests :: TestTree highlightTests = testGroup "highlight" [ testSessionWait "value" $ do@@ -4404,34 +4508,26 @@ , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ]- ,-#if MIN_VERSION_ghc(9,0,0)- expectFailBecause "Ghc9 highlights the constructor and not just this field" $-#endif- testSessionWait "record" $ do- doc <- createDoc "A.hs" "haskell" recsource- _ <- waitForDiagnostics- highlights <- getHighlights doc (Position 4 15)- liftIO $ highlights @?= List- -- Span is just the .. on 8.10, but Rec{..} before- [-#if MIN_VERSION_ghc(8,10,0)- DocumentHighlight (R 4 8 4 10) (Just HkWrite)-#else- DocumentHighlight (R 4 4 4 11) (Just HkWrite)-#endif- , DocumentHighlight (R 4 14 4 20) (Just HkRead)- ]- highlights <- getHighlights doc (Position 3 17)- liftIO $ highlights @?= List- [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)- -- Span is just the .. on 8.10, but Rec{..} before-#if MIN_VERSION_ghc(8,10,0)- , DocumentHighlight (R 4 8 4 10) (Just HkRead)-#else- , DocumentHighlight (R 4 4 4 11) (Just HkRead)-#endif- ]+ , knownBrokenForGhcVersions [GHC90] "Ghc9 highlights the constructor and not just this field" $+ testSessionWait "record" $ do+ doc <- createDoc "A.hs" "haskell" recsource+ _ <- waitForDiagnostics+ highlights <- getHighlights doc (Position 4 15)+ liftIO $ highlights @?= List+ -- Span is just the .. on 8.10, but Rec{..} before+ [ if ghcVersion >= GHC810+ then DocumentHighlight (R 4 8 4 10) (Just HkWrite)+ else DocumentHighlight (R 4 4 4 11) (Just HkWrite)+ , DocumentHighlight (R 4 14 4 20) (Just HkRead)+ ]+ highlights <- getHighlights doc (Position 3 17)+ liftIO $ highlights @?= List+ [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)+ -- Span is just the .. on 8.10, but Rec{..} before+ , if ghcVersion >= GHC810+ then DocumentHighlight (R 4 8 4 10) (Just HkRead)+ else DocumentHighlight (R 4 4 4 11) (Just HkRead)+ ] ] where source = T.unlines@@ -4636,24 +4732,28 @@ xfail = flip expectFailBecause ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x)+ignoreInWindowsBecause+ | isWindows = ignoreTestBecause+ | otherwise = \_ x -> x ignoreInWindowsForGHC88And810 :: TestTree -> TestTree-#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(9,0,0)-ignoreInWindowsForGHC88And810 =- ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10"-#else-ignoreInWindowsForGHC88And810 = id-#endif+ignoreInWindowsForGHC88And810+ | ghcVersion `elem` [GHC88, GHC810] =+ ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10"+ | otherwise = id ignoreInWindowsForGHC88 :: TestTree -> TestTree-#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(8,10,1)-ignoreInWindowsForGHC88 =- ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8"-#else-ignoreInWindowsForGHC88 = id-#endif+ignoreInWindowsForGHC88+ | ghcVersion == GHC88 =+ ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8"+ | otherwise = id +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree+knownBrokenForGhcVersions ghcVers+ | ghcVersion `elem` ghcVers = expectFailBecause+ | otherwise = \_ x -> x++ data Expect = ExpectRange Range -- Both gotoDef and hover should report this range | ExpectLocation Location@@ -4811,13 +4911,11 @@ let bazContent = T.unlines ["module Baz where", "import Foo ()"] _ <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent- expectDiagnostics-#if MIN_VERSION_ghc(9,0,0)- -- String vs [Char] causes this change in error message- [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])]-#else- [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]-#endif+ expectDiagnostics $+ if ghcVersion >= GHC90+ -- String vs [Char] causes this change in error message+ then [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])]+ else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $@@ -5083,13 +5181,11 @@ "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent- expectDiagnostics-#if MIN_VERSION_ghc(9,0,0)- -- String vs [Char] causes this change in error message- [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]-#else- [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]-#endif+ expectDiagnostics $+ if ghcVersion >= GHC90+ -- String vs [Char] causes this change in error message+ then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]+ else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8@@ -5145,6 +5241,7 @@ assertBool "did not successfully complete 5 repetitions" $ Bench.success res | e <- Bench.experiments , Bench.name e /= "edit" -- the edit experiment does not ever fail+ , Bench.name e /= "hole fit suggestions" -- is too slow! -- the cradle experiments are way too slow , not ("cradle" `isInfixOf` Bench.name e) ]@@ -5799,16 +5896,10 @@ -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text-#if MIN_VERSION_ghc(9,0,1)-listOfChar = "String"-#else-listOfChar = "[Char]"-#endif+listOfChar | ghcVersion >= GHC90 = "String"+ | otherwise = "[Char]" -- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did thDollarIdx :: Int-#if MIN_VERSION_ghc(9,0,1)-thDollarIdx = 1-#else-thDollarIdx = 0-#endif+thDollarIdx | ghcVersion >= GHC90 = 1+ | otherwise = 0
test/src/Development/IDE/Test.hs view
@@ -33,39 +33,26 @@ import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult)+import Development.IDE.Test.Diagnostic import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest-import Language.LSP.Types+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length),+ SemanticTokensEdit (_start)) import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) import System.Time.Extra import Test.Tasty.HUnit --- | (0-based line number, 0-based column number)-type Cursor = (Int, Int)--cursorPosition :: Cursor -> Position-cursorPosition (line, col) = Position line col--requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion-requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do- unless (any match actuals) $- assertFailure $- "Could not find " <> show expected <>- " in " <> show actuals- where- match :: Diagnostic -> Bool- match d =- Just severity == _severity d- && cursorPosition cursor == d ^. range . start- && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`- standardizeQuotes (T.toLower $ d ^. message)- && hasTag expectedTag (d ^. tags)-- hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool- hasTag Nothing _ = True- hasTag (Just _) Nothing = False- hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags+requireDiagnosticM+ :: (Foldable f, Show (f Diagnostic), HasCallStack)+ => f Diagnostic+ -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)+ -> Assertion+requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of+ Nothing -> pure ()+ Just err -> assertFailure err -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period@@ -154,7 +141,7 @@ <> " got " <> show actual Just expected -> do- liftIO $ mapM_ (requireDiagnostic actual) expected+ liftIO $ mapM_ (requireDiagnosticM actual) expected liftIO $ unless (length expected == length actual) $ assertFailure $@@ -181,14 +168,6 @@ diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics--standardizeQuotes :: T.Text -> T.Text-standardizeQuotes msg = let- repl '‘' = '\''- repl '’' = '\''- repl '`' = '\''- repl c = c- in T.map repl msg waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do
+ test/src/Development/IDE/Test/Diagnostic.hs view
@@ -0,0 +1,47 @@+module Development.IDE.Test.Diagnostic where++import Control.Lens ((^.))+import qualified Data.Text as T+import GHC.Stack (HasCallStack)+import Language.LSP.Types+import Language.LSP.Types.Lens as Lsp++-- | (0-based line number, 0-based column number)+type Cursor = (Int, Int)++cursorPosition :: Cursor -> Position+cursorPosition (line, col) = Position line col++type ErrorMsg = String++requireDiagnostic+ :: (Foldable f, Show (f Diagnostic), HasCallStack)+ => f Diagnostic+ -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)+ -> Maybe ErrorMsg+requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag)+ | any match actuals = Nothing+ | otherwise = Just $+ "Could not find " <> show expected <>+ " in " <> show actuals+ where+ match :: Diagnostic -> Bool+ match d =+ Just severity == _severity d+ && cursorPosition cursor == d ^. range . start+ && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`+ standardizeQuotes (T.toLower $ d ^. message)+ && hasTag expectedTag (d ^. tags)++ hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool+ hasTag Nothing _ = True+ hasTag (Just _) Nothing = False+ hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags++standardizeQuotes :: T.Text -> T.Text+standardizeQuotes msg = let+ repl '‘' = '\''+ repl '’' = '\''+ repl '`' = '\''+ repl c = c+ in T.map repl msg