packages feed

ghcide 0.7.0.0 → 0.7.1.0

raw patch · 80 files changed

+20207/−19381 lines, 80 filesdep +dlistdep +ghc-exactprintdep +retriedep ~haskell-lspdep ~haskell-lsp-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dlist, ghc-exactprint, retrie, vector

Dependency ranges changed: haskell-lsp, haskell-lsp-types

API changes (from Hackage documentation)

- Development.IDE.Core.Shake: instance Control.DeepSeq.NFData (Development.IDE.Core.Shake.A v)
- Development.IDE.Core.Shake: instance Control.DeepSeq.NFData Development.IDE.Core.Shake.ShakeValue
- Development.IDE.Core.Shake: instance Control.DeepSeq.NFData k => Control.DeepSeq.NFData (Development.IDE.Core.Shake.Q k)
- Development.IDE.Core.Shake: instance Data.Binary.Class.Binary k => Data.Binary.Class.Binary (Development.IDE.Core.Shake.Q k)
- Development.IDE.Core.Shake: instance Data.Hashable.Class.Hashable k => Data.Hashable.Class.Hashable (Development.IDE.Core.Shake.Q k)
- Development.IDE.Core.Shake: instance GHC.Classes.Eq k => GHC.Classes.Eq (Development.IDE.Core.Shake.Q k)
- Development.IDE.Core.Shake: instance GHC.Exception.Type.Exception Development.IDE.Core.Shake.BadDependency
- Development.IDE.Core.Shake: instance GHC.Generics.Generic Development.IDE.Core.Shake.ShakeValue
- Development.IDE.Core.Shake: instance GHC.Show.Show Development.IDE.Core.Shake.BadDependency
- Development.IDE.Core.Shake: instance GHC.Show.Show Development.IDE.Core.Shake.ShakeValue
- Development.IDE.Core.Shake: instance GHC.Show.Show k => GHC.Show.Show (Development.IDE.Core.Shake.Q k)
- Development.IDE.Core.Shake: instance GHC.Show.Show v => GHC.Show.Show (Development.IDE.Core.Shake.A v)
+ Development.IDE: Splices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] -> [(LHsExpr GhcTc, LPat GhcPs)] -> [(LHsExpr GhcTc, LHsType GhcPs)] -> [(LHsExpr GhcTc, [LHsDecl GhcPs])] -> [(LHsExpr GhcTc, Serialized)] -> Splices
+ Development.IDE: [awSplices] :: Splices -> [(LHsExpr GhcTc, Serialized)]
+ Development.IDE: [declSplices] :: Splices -> [(LHsExpr GhcTc, [LHsDecl GhcPs])]
+ Development.IDE: [exprSplices] :: Splices -> [(LHsExpr GhcTc, LHsExpr GhcPs)]
+ Development.IDE: [patSplices] :: Splices -> [(LHsExpr GhcTc, LPat GhcPs)]
+ Development.IDE: [tmrTopLevelSplices] :: TcModuleResult -> Splices
+ Development.IDE: [typeSplices] :: Splices -> [(LHsExpr GhcTc, LHsType GhcPs)]
+ Development.IDE: awSplicesL :: Lens' Splices [(LHsExpr GhcTc, Serialized)]
+ Development.IDE: data Splices
+ Development.IDE: declSplicesL :: Lens' Splices [(LHsExpr GhcTc, [LHsDecl GhcPs])]
+ Development.IDE: exprSplicesL :: Lens' Splices [(LHsExpr GhcTc, LHsExpr GhcPs)]
+ Development.IDE: patSplicesL :: Lens' Splices [(LHsExpr GhcTc, LPat GhcPs)]
+ Development.IDE: typeSplicesL :: Lens' Splices [(LHsExpr GhcTc, LHsType GhcPs)]
+ Development.IDE.Core.RuleTypes: Splices :: [(LHsExpr GhcTc, LHsExpr GhcPs)] -> [(LHsExpr GhcTc, LPat GhcPs)] -> [(LHsExpr GhcTc, LHsType GhcPs)] -> [(LHsExpr GhcTc, [LHsDecl GhcPs])] -> [(LHsExpr GhcTc, Serialized)] -> Splices
+ Development.IDE.Core.RuleTypes: [awSplices] :: Splices -> [(LHsExpr GhcTc, Serialized)]
+ Development.IDE.Core.RuleTypes: [declSplices] :: Splices -> [(LHsExpr GhcTc, [LHsDecl GhcPs])]
+ Development.IDE.Core.RuleTypes: [exprSplices] :: Splices -> [(LHsExpr GhcTc, LHsExpr GhcPs)]
+ Development.IDE.Core.RuleTypes: [patSplices] :: Splices -> [(LHsExpr GhcTc, LPat GhcPs)]
+ Development.IDE.Core.RuleTypes: [tmrTopLevelSplices] :: TcModuleResult -> Splices
+ Development.IDE.Core.RuleTypes: [typeSplices] :: Splices -> [(LHsExpr GhcTc, LHsType GhcPs)]
+ Development.IDE.Core.RuleTypes: awSplicesL :: Lens' Splices [(LHsExpr GhcTc, Serialized)]
+ Development.IDE.Core.RuleTypes: data Splices
+ Development.IDE.Core.RuleTypes: declSplicesL :: Lens' Splices [(LHsExpr GhcTc, [LHsDecl GhcPs])]
+ Development.IDE.Core.RuleTypes: exprSplicesL :: Lens' Splices [(LHsExpr GhcTc, LHsExpr GhcPs)]
+ Development.IDE.Core.RuleTypes: instance Control.DeepSeq.NFData Development.IDE.Core.RuleTypes.Splices
+ Development.IDE.Core.RuleTypes: instance GHC.Base.Monoid Development.IDE.Core.RuleTypes.Splices
+ Development.IDE.Core.RuleTypes: instance GHC.Base.Semigroup Development.IDE.Core.RuleTypes.Splices
+ Development.IDE.Core.RuleTypes: patSplicesL :: Lens' Splices [(LHsExpr GhcTc, LPat GhcPs)]
+ Development.IDE.Core.RuleTypes: typeSplicesL :: Lens' Splices [(LHsExpr GhcTc, LHsType GhcPs)]
+ Development.IDE.Core.Rules: CompiledLinkables :: Var (ModuleEnv UTCTime) -> CompiledLinkables
+ Development.IDE.Core.Rules: IsHiFileStable :: IsHiFileStable
+ Development.IDE.Core.Rules: [$sel:getCompiledLinkables:CompiledLinkables] :: CompiledLinkables -> Var (ModuleEnv UTCTime)
+ Development.IDE.Core.Rules: data IsHiFileStable
+ Development.IDE.Core.Rules: generateCoreRule :: Rules ()
+ Development.IDE.Core.Rules: getBindingsRule :: Rules ()
+ Development.IDE.Core.Rules: getClientSettingsRule :: Rules ()
+ Development.IDE.Core.Rules: getDependenciesRule :: Rules ()
+ Development.IDE.Core.Rules: getDependencyInformationRule :: Rules ()
+ Development.IDE.Core.Rules: getDocMapRule :: Rules ()
+ Development.IDE.Core.Rules: getHieAstsRule :: Rules ()
+ Development.IDE.Core.Rules: getImportMapRule :: Rules ()
+ Development.IDE.Core.Rules: getLocatedImportsRule :: Rules ()
+ Development.IDE.Core.Rules: getModIfaceFromDiskRule :: Rules ()
+ Development.IDE.Core.Rules: getModIfaceRule :: Rules ()
+ Development.IDE.Core.Rules: getModIfaceWithoutLinkableRule :: Rules ()
+ Development.IDE.Core.Rules: getModSummaryRule :: Rules ()
+ Development.IDE.Core.Rules: getModuleGraphRule :: Rules ()
+ Development.IDE.Core.Rules: getParsedModuleRule :: Rules ()
+ Development.IDE.Core.Rules: isHiFileStableRule :: Rules ()
+ Development.IDE.Core.Rules: knownFilesRule :: Rules ()
+ Development.IDE.Core.Rules: loadGhcSession :: Rules ()
+ Development.IDE.Core.Rules: needsCompilationRule :: Rules ()
+ Development.IDE.Core.Rules: newtype CompiledLinkables
+ Development.IDE.Core.Rules: reportImportCyclesRule :: Rules ()
+ Development.IDE.Core.Rules: typeCheckRule :: Rules ()
+ Development.IDE.GHC.Compat: dropForAll :: LHsType pass -> LHsType pass
+ Development.IDE.GHC.ExactPrint: ExceptStringT :: ExceptT String m a -> ExceptStringT m a
+ Development.IDE.GHC.ExactPrint: Graft :: (DynFlags -> a -> TransformT m a) -> Graft m a
+ Development.IDE.GHC.ExactPrint: [runExceptString] :: ExceptStringT m a -> ExceptT String m a
+ Development.IDE.GHC.ExactPrint: [runGraft] :: Graft m a -> DynFlags -> a -> TransformT m a
+ Development.IDE.GHC.ExactPrint: annotateParsedSource :: ParsedModule -> Annotated ParsedSource
+ Development.IDE.GHC.ExactPrint: class (Data ast, Outputable ast) => ASTElement ast
+ Development.IDE.GHC.ExactPrint: graft :: forall ast a. (Data a, ASTElement ast) => SrcSpan -> Located ast -> Graft (Either String) a
+ Development.IDE.GHC.ExactPrint: graftDecls :: forall a. HasDecls a => SrcSpan -> [LHsDecl GhcPs] -> Graft (Either String) a
+ Development.IDE.GHC.ExactPrint: graftDeclsWithM :: forall a m. (HasDecls a, MonadFail m) => SrcSpan -> (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) -> Graft m a
+ Development.IDE.GHC.ExactPrint: graftWithM :: forall ast m a. (MonadFail m, Data a, ASTElement ast) => SrcSpan -> (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a
+ Development.IDE.GHC.ExactPrint: graftWithSmallestM :: forall ast m a. (MonadFail m, Data a, ASTElement ast) => SrcSpan -> (Located ast -> TransformT m (Maybe (Located ast))) -> Graft m a
+ Development.IDE.GHC.ExactPrint: hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a
+ Development.IDE.GHC.ExactPrint: instance (Data.Functor.Classes.Eq1 m, GHC.Classes.Eq a) => GHC.Classes.Eq (Development.IDE.GHC.ExactPrint.ExceptStringT m a)
+ Development.IDE.GHC.ExactPrint: instance (Data.Functor.Classes.Ord1 m, GHC.Classes.Ord a) => GHC.Classes.Ord (Development.IDE.GHC.ExactPrint.ExceptStringT m a)
+ Development.IDE.GHC.ExactPrint: instance (Data.Functor.Classes.Read1 m, GHC.Read.Read a) => GHC.Read.Read (Development.IDE.GHC.ExactPrint.ExceptStringT m a)
+ Development.IDE.GHC.ExactPrint: instance (Data.Functor.Classes.Show1 m, GHC.Show.Show a) => GHC.Show.Show (Development.IDE.GHC.ExactPrint.ExceptStringT m a)
+ Development.IDE.GHC.ExactPrint: instance (p GHC.Types.~ GHC.Hs.Extension.GhcPs) => Development.IDE.GHC.ExactPrint.ASTElement (GHC.Hs.Decls.HsDecl p)
+ Development.IDE.GHC.ExactPrint: instance (p GHC.Types.~ GHC.Hs.Extension.GhcPs) => Development.IDE.GHC.ExactPrint.ASTElement (GHC.Hs.Expr.HsExpr p)
+ Development.IDE.GHC.ExactPrint: instance (p GHC.Types.~ GHC.Hs.Extension.GhcPs) => Development.IDE.GHC.ExactPrint.ASTElement (GHC.Hs.Pat.Pat p)
+ Development.IDE.GHC.ExactPrint: instance (p GHC.Types.~ GHC.Hs.Extension.GhcPs) => Development.IDE.GHC.ExactPrint.ASTElement (GHC.Hs.Types.HsType p)
+ Development.IDE.GHC.ExactPrint: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Control.Monad.Trans.Class.MonadTrans Development.IDE.GHC.ExactPrint.ExceptStringT
+ Development.IDE.GHC.ExactPrint: instance Control.Monad.Zip.MonadZip m => Control.Monad.Zip.MonadZip (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Foldable.Foldable m => Data.Foldable.Foldable (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Functor.Classes.Eq1 m => Data.Functor.Classes.Eq1 (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Functor.Classes.Ord1 m => Data.Functor.Classes.Ord1 (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Functor.Classes.Read1 m => Data.Functor.Classes.Read1 (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Functor.Classes.Show1 m => Data.Functor.Classes.Show1 (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance Data.Functor.Contravariant.Contravariant m => Data.Functor.Contravariant.Contravariant (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Functor m => GHC.Base.Functor (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => Control.Monad.Fail.MonadFail (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.Alternative (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.Applicative (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.Monad (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.MonadPlus (Development.IDE.GHC.ExactPrint.ExceptStringT m)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.Monoid (Development.IDE.GHC.ExactPrint.Graft m a)
+ Development.IDE.GHC.ExactPrint: instance GHC.Base.Monad m => GHC.Base.Semigroup (Development.IDE.GHC.ExactPrint.Graft m a)
+ Development.IDE.GHC.ExactPrint: maybeParensAST :: ASTElement ast => Located ast -> Located ast
+ Development.IDE.GHC.ExactPrint: newtype ExceptStringT m a
+ Development.IDE.GHC.ExactPrint: newtype Graft m a
+ Development.IDE.GHC.ExactPrint: parseAST :: ASTElement ast => Parser (Located ast)
+ Development.IDE.GHC.ExactPrint: transform :: DynFlags -> ClientCapabilities -> Uri -> Graft (Either String) ParsedSource -> Annotated ParsedSource -> Either String WorkspaceEdit
+ Development.IDE.GHC.ExactPrint: transformM :: Monad m => DynFlags -> ClientCapabilities -> Uri -> Graft (ExceptStringT m) ParsedSource -> Annotated ParsedSource -> m (Either String WorkspaceEdit)
+ Development.IDE.GHC.ExactPrint: useAnnotatedSource :: String -> IdeState -> NormalizedFilePath -> IO (Maybe (Annotated ParsedSource))
+ Development.IDE.GHC.Orphans: instance Data.Aeson.Types.FromJSON.FromJSON SrcLoc.RealSrcSpan
+ Development.IDE.GHC.Orphans: instance Data.Aeson.Types.ToJSON.ToJSON SrcLoc.RealSrcSpan
+ Development.IDE.Types.Shake: A :: Value v -> A v
+ Development.IDE.Types.Shake: BadDependency :: String -> BadDependency
+ Development.IDE.Types.Shake: Q :: (k, NormalizedFilePath) -> Q k
+ Development.IDE.Types.Shake: ShakeNoCutoff :: ShakeValue
+ Development.IDE.Types.Shake: ShakeResult :: !ByteString -> ShakeValue
+ Development.IDE.Types.Shake: ShakeStale :: !ByteString -> ShakeValue
+ Development.IDE.Types.Shake: ValueWithDiagnostics :: !Value Dynamic -> !Vector FileDiagnostic -> ValueWithDiagnostics
+ Development.IDE.Types.Shake: data ShakeValue
+ Development.IDE.Types.Shake: data ValueWithDiagnostics
+ Development.IDE.Types.Shake: decodeShakeValue :: ByteString -> ShakeValue
+ Development.IDE.Types.Shake: encodeShakeValue :: ShakeValue -> ByteString
+ Development.IDE.Types.Shake: instance Control.DeepSeq.NFData (Development.IDE.Types.Shake.A v)
+ Development.IDE.Types.Shake: instance Control.DeepSeq.NFData Development.IDE.Types.Shake.ShakeValue
+ Development.IDE.Types.Shake: instance Control.DeepSeq.NFData k => Control.DeepSeq.NFData (Development.IDE.Types.Shake.Q k)
+ Development.IDE.Types.Shake: instance Data.Binary.Class.Binary k => Data.Binary.Class.Binary (Development.IDE.Types.Shake.Q k)
+ Development.IDE.Types.Shake: instance Data.Hashable.Class.Hashable k => Data.Hashable.Class.Hashable (Development.IDE.Types.Shake.Q k)
+ Development.IDE.Types.Shake: instance GHC.Classes.Eq k => GHC.Classes.Eq (Development.IDE.Types.Shake.Q k)
+ Development.IDE.Types.Shake: instance GHC.Exception.Type.Exception Development.IDE.Types.Shake.BadDependency
+ Development.IDE.Types.Shake: instance GHC.Generics.Generic Development.IDE.Types.Shake.ShakeValue
+ Development.IDE.Types.Shake: instance GHC.Show.Show Development.IDE.Types.Shake.BadDependency
+ Development.IDE.Types.Shake: instance GHC.Show.Show Development.IDE.Types.Shake.ShakeValue
+ Development.IDE.Types.Shake: instance GHC.Show.Show k => GHC.Show.Show (Development.IDE.Types.Shake.Q k)
+ Development.IDE.Types.Shake: instance GHC.Show.Show v => GHC.Show.Show (Development.IDE.Types.Shake.A v)
+ Development.IDE.Types.Shake: isBadDependency :: SomeException -> Bool
+ Development.IDE.Types.Shake: newtype A v
+ Development.IDE.Types.Shake: newtype BadDependency
+ Development.IDE.Types.Shake: newtype Q k
+ Development.IDE.Types.Shake: toShakeValue :: (ByteString -> ShakeValue) -> Maybe ByteString -> ShakeValue
- Development.IDE: TcModuleResult :: ParsedModule -> RenamedSource -> TcGblEnv -> !Bool -> TcModuleResult
+ Development.IDE: TcModuleResult :: ParsedModule -> RenamedSource -> TcGblEnv -> Splices -> !Bool -> TcModuleResult
- Development.IDE.Core.RuleTypes: TcModuleResult :: ParsedModule -> RenamedSource -> TcGblEnv -> !Bool -> TcModuleResult
+ Development.IDE.Core.RuleTypes: TcModuleResult :: ParsedModule -> RenamedSource -> TcGblEnv -> Splices -> !Bool -> TcModuleResult
- Development.IDE.Plugin.Completions: getCompletionsLSP :: LspFuncs cofd -> IdeState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult)
+ Development.IDE.Plugin.Completions: getCompletionsLSP :: LspFuncs Config -> IdeState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult)
- Development.IDE.Plugin.Completions: plugin :: Plugin c
+ Development.IDE.Plugin.Completions: plugin :: Plugin Config
- Development.IDE.Types.Shake: type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic)
+ Development.IDE.Types.Shake: type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics

Files

CHANGELOG.md view
@@ -1,217 +1,232 @@-### 0.7.0 (2020-01-03)
-
-* Retry a failed cradle if the cradle descriptor changes (#762) - (Pepe Iborra)
-* Fix extend imports regression (#769) - (Pepe Iborra)
-* Perform memory measurement on SIGUSR1 (#761) - (Pepe Iborra)
-
-### 0.6.0.2 (2020-12-26)
-* Fix disappearing diagnostics bug (#959) - (Pepe Iborra)
-* Deduplicate module not found diagnostics (#952) - (Pepe Iborra)
-* Use qualified module name from diagnostics in suggestNewImport (#945) - (Potato Hatsue)
-* Disable auto extend import snippets in completions (these need a bit more work)
-
-### 0.6.0.1 (2020-12-13)
-* Fix build with GHC 8.8.2 and 8.8.3 - (Javier Neira)
-* Update old URLs still pointing to digital-asset - (Jan Hrcek)
-
-### 0.6.0 (2020-12-06)
-* Completions: extend explicit import list automatically (#930) - (Guru Devanla)
-* Completions for identifiers not in explicit import lists (#919) - (Guru Devanla)
-* Completions for record fields (#900) - (Guru Devanla)
-* Bugfix: add constructors to import lists correctly (#916) - (Potato Hatsue)
-* Bugfix: respect qualified identifiers (#938) - (Pepe Iborra)
-* Bugfix: partial `pathToId` (#926) - (Samuel Ainsworth)
-* Bugfix: import suggestions when there's more than one option (#913) - (Guru Devanla)
-* Bugfix: parenthesize operators when exporting (#906) - (Potato Hatsue)
-* Opentelemetry traces and heapsize memory analysis (#922) - (Michalis Pardalos / Pepe Iborra)
-* Make Filetargets absolute before continue using them (#914) - (fendor)
-* Do not enable every "unnecessary" warning by default (#907) - (Alejandro Serrano)
-* Update implicit-hie to 0.3.0 (#905) - (Avi Dessauer)
-
-### 0.5.0 (2020-11-07)
-* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira)
-* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer)
-* Switch back to bytecode (#873) - (wz1000)
-* Add code action for remove all redundant imports (#867) - (Potato Hatsue)
-* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett)
-* Canonicalize import dirs (#870) - (Pepe Iborra)
-* Do not show internal hole names (#852) - (Alejandro Serrano)
-* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering)
-* Pull in local bindings (#845) - (Sandy Maguire)
-* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000)
-* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek)
-* Fix duplicated completions (#837) - (Vitalii)
-* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones)
-* Drop 8.4 support (#834) - (wz1000)
-* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000)
-* Tag unused warning as such (#815) - (Alejandro Serrano)
-* Update instructions for stty error in windows (#825) - (Javier Neira)
-* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets)
-* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets)
-* Add completion tests for records. (#804) - (Guru Devanla)
-* Restore identifiers missing from hi file (#741) - (maralorn)
-* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni)
-
-### 0.4.0 (2020-09-15)
-* Fixes for GHC source plugins: dotpreprocessor works now - (srid)
-* Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira)
-* Extend position mapping with fuzzy ranges (#785) - (wz1000)
-* Sort import suggestions (#793) - (Pepe Iborra)
-* Save source files with HIE files (#701) - (fendor)
-* Fully asynchronous request handling (#767) - (Pepe Iborra)
-* Refinement holes (#748) - (Pepe Iborra)
-* Fix haddock to markdown conversion (#757) - (George Thomas)
-* Expose `getCompletionsLSP` to allow completions in hls (#756) - (wz1000)
-* Suggestions for missing imports from local modules (#739) - (Pepe Iborra)
-* Dynamically load libm on Linux for each new session (#723) - (Luke Lau)
-* Use InitializeParams.rootUri for initial session setup (#713) - (shaurya gupta)
-* Show documentation on hover for symbols defined in the same module (#691) - (wz1000)
-* Suggest open imports (#740) - (Pepe Iborra)
-* module Development.IDE (#724) - (Pepe Iborra)
-* Ignore -Werror (#738) - (Pepe Iborra)
-* Fix issue #710: fix suggest delete binding  (#728) - (Ray Shih)
-* Generate doc file URL via LSP (to fix it for Windows) (#721) - (Nick Dunets)
-* Fix `.hie` file location for `.hs-boot` files (#690) - (wz1000)
-* Use argsVerbose to determine log level in test mode (#717) - (Ziyang Liu)
-* output which cradle files were found (#716) - (Adam Sandberg Eriksson)
-* Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688) - (wz1000)
-
-### 0.3.0 (2020-09-02)
-
-* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen)
-* Add session-loader to hie.yaml (#714) - (Luke Lau)
-* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta)
-* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau)
-* Expose GHC.Compat module (#709) - (Pepe Iborra)
-* Move session loading logic into ghcide library (#697) - (Luke Lau)
-* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato)
-* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer)
-* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra)
-* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli)
-* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra)
-* Obtain the GHC libdir at runtime (#696) - (Luke Lau)
-* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra)
-* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot])
-* Update to hie-bios 0.6.1 (#693) - (fendor)
-* Backport HIE files to GHC 8.6 (#689) - (wz1000)
-* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra)
-* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii)
-* Use a global namecache to read `.hie` files (#677) - (wz1000)
-* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra)
-* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra)
-* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra)
-* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering)
-* Code action: add constraint (#653) - (Denis Frezzato)
-* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra)
-* Delete unused top level binding code action (#657) - (Serhii)
-* stack810.yaml: bump (#651) - (Domen Kozar)
-* Fix debouncer for 0 delay (#662) - (Pepe Iborra)
-* Interface file fixes (#645) - (Pepe Iborra)
-* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer)
-* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra)
-* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra)
-* Add a note on differential benchmarks (#647) - (Pepe Iborra)
-* Cache a ghc session per file of interest (#630) - (Pepe Iborra)
-* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits)
-* Report progress when setting up cradle (#644) - (Luke Lau)
-* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra)
-* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra)
-* Performance analysis over time (#629) - (Pepe Iborra)
-* More benchmarks (#625) - (Pepe Iborra)
-* Canonicalize the locations in the cradle tests (#628) - (Luke Lau)
-* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira)
-* Fix a bug in getHiFileRule (#623) - (Pepe Iborra)
-* ghc initialization error handling (#609) - (Pepe Iborra)
-* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra)
-* Restore Shake profiling (#621) - (Pepe Iborra)
-* Use a better noRange (#612) - (Neil Mitchell)
-* Add back a .ghci file (#607) - (Neil Mitchell)
-* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell)
-* Implement Goto Type Definition (#533) - (Matthew Pickering)
-* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra)
-* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra)
-* Benchmark suite (#590) - (Pepe Iborra)
-
-### 0.2.0 (2020-06-02)
-
-* Multi-component support (thanks @mpickering)
-* Support for GHC 8.10 (thanks @sheaf and @chshersh)
-* Fix some TH issues (thanks @mpickering)
-* Automatically pick up changes to cradle dependencies (e.g. cabal
-  files) (thanks @jinwoo)
-* Track dependencies when using `qAddDependentFile` (thanks @mpickering)
-* Add record fields to document symbols outline (thanks @bubba)
-* Fix some space leaks (thanks @mpickering)
-* Strip redundant path information from diagnostics (thanks @tek)
-* Fix import suggestions for operators (thanks @eddiemundo)
-* Significant reductions in memory usage by using interfaces and `.hie` files (thanks
-  @pepeiborra)
-* Minor improvements to completions
-* More comprehensive suggestions for missing imports (thanks @pepeiborra)
-* Group imports in document outline (thanks @fendor)
-* Upgrade to haskell-lsp-0.22 (thanks @bubba)
-* Upgrade to hie-bios 0.5 (thanks @fendor)
-
-### 0.1.0 (2020-02-04)
-
-* Code action for inserting new definitions (see #309).
-* Better default GC settings (see #329 and #333).
-* Various performance improvements (see #322 and #384).
-* Improvements to hover information (see #317 and #338).
-* Support GHC 8.8.2 (see #355).
-* Include keywords in completions (see #351).
-* Fix some issues with aborted requests (see #353).
-* Use hie-bios 0.4.0 (see #382).
-* Avoid stuck progress reporting (see #400).
-* Only show progress notifications after 0.1s (see #392).
-* Progress reporting is now in terms of the number of files rather
-  than the number of shake rules (see #379).
-
-### 0.0.6 (2020-01-10)
-
-* Fix type in hover information for do-notation and list
-  comprehensions (see #243).
-* Fix hover and goto-definition for multi-clause definitions (see #252).
-* Upgrade to `hie-bios-0.3` (see #257)
-* Upgrade to `haskell-lsp-0.19` (see #254)
-* Code lenses for missing signatures are displayed even if the warning
-  has not been enabled. The warning itself will not be shown if it is
-  not enabled. (see #232)
-* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific
-  workarounds. (see #264)
-* Fix some filepath normalization issues. (see #266)
-* Fix build with `shake-0.18.4` (see #272)
-* Fix hover for type constructors and type classes. (see #267)
-* Support custom preprocessors (see #282)
-* Add support for code completions (see #227)
-* Code action for removing redundant symbols from imports (see #290)
-* Support document symbol requests (see #293)
-* Show CPP errors as diagnostics (see #296)
-* Code action for adding suggested imports (see #295)
-
-### 0.0.5 (2019-12-12)
-
-* Support for GHC plugins (see #192)
-* Update to haskell-lsp 0.18 (see #203)
-* Initial support for `TemplateHaskell` (see #222)
-* Code lenses for missing signatures. These are only shown if
-  `-Wmissing-signatures` is enabled. (see #224)
-* Fix path normalisation on Windows (see #225)
-* Fix flickering of the progress indicator (see #230)
-
-### 0.0.4 (2019-10-20)
-
-* Add a ``--version`` cli option (thanks @jacg)
-* Update to use progress reporting as defined in LSP 3.15. The VSCode
-  extension has also been updated and should now be making use of
-  this.
-* Properly declare that we should support code actions. This helps
-  with some clients that rely on this information to enable code
-  actions (thanks @jacg).
-* Fix a race condition caused by sharing the finder cache between
-  concurrent compilations.
-* Avoid normalizing include dirs. This avoids issues where the same
-  file ends up twice in the module graph, e.g., with different casing
-  for drive letters.
-
-### 0.0.3 (2019-09-21)
+### 0.7.1 (2020-01-13)++* Fix sticky diagnostics bug (#1188) - (Pepe Iborra)+* Use completionSnippetsOn flag (#1195) - (Yuya Kono)+* Update tested-with GHC in cabal config - (jneira)+* Do not disable parallel GC by default (#1190) - (Pepe Iborra)+* Fix module outline becoming stale after switching branches (#1189) - (Pepe Iborra)+* Make adding missing constraint work in presence of 'forall' (fixes #1164) (#1177) - (Jan Hrcek)+* Bump haskell-lsp to 0.23 (#1146) - (Potato Hatsue)+* Fix #723 (Instance declarations in hs-boot files result in GHC errors) (#781) - (Ben Simms)+* Also suggest importing methods without parent class (#766) - (Thomas Winant)+* Update links to issues/PRs in ghcide tests. (#1142) - (Peter Wicks Stringfield)+* fix suggestAddTypeAnnotation regex (#760) - (Kostas Dermentzis)++### 0.7.0 (2020-01-03)++* Ghcide now loads HLS plugins internally - (Pepe Iborra)+* Retry a failed cradle if the cradle descriptor changes (#762) - (Pepe Iborra)+* Fix extend imports regression (#769) - (Pepe Iborra)+* Perform memory measurement on SIGUSR1 (#761) - (Pepe Iborra)++### 0.6.0.2 (2020-12-26)+* Fix disappearing diagnostics bug (#959) - (Pepe Iborra)+* Deduplicate module not found diagnostics (#952) - (Pepe Iborra)+* Use qualified module name from diagnostics in suggestNewImport (#945) - (Potato Hatsue)+* Disable auto extend import snippets in completions (these need a bit more work)++### 0.6.0.1 (2020-12-13)+* Fix build with GHC 8.8.2 and 8.8.3 - (Javier Neira)+* Update old URLs still pointing to digital-asset - (Jan Hrcek)++### 0.6.0 (2020-12-06)+* Completions: extend explicit import list automatically (#930) - (Guru Devanla)+* Completions for identifiers not in explicit import lists (#919) - (Guru Devanla)+* Completions for record fields (#900) - (Guru Devanla)+* Bugfix: add constructors to import lists correctly (#916) - (Potato Hatsue)+* Bugfix: respect qualified identifiers (#938) - (Pepe Iborra)+* Bugfix: partial `pathToId` (#926) - (Samuel Ainsworth)+* Bugfix: import suggestions when there's more than one option (#913) - (Guru Devanla)+* Bugfix: parenthesize operators when exporting (#906) - (Potato Hatsue)+* Opentelemetry traces and heapsize memory analysis (#922) - (Michalis Pardalos / Pepe Iborra)+* Make Filetargets absolute before continue using them (#914) - (fendor)+* Do not enable every "unnecessary" warning by default (#907) - (Alejandro Serrano)+* Update implicit-hie to 0.3.0 (#905) - (Avi Dessauer)++### 0.5.0 (2020-11-07)+* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira)+* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer)+* Switch back to bytecode (#873) - (wz1000)+* Add code action for remove all redundant imports (#867) - (Potato Hatsue)+* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett)+* Canonicalize import dirs (#870) - (Pepe Iborra)+* Do not show internal hole names (#852) - (Alejandro Serrano)+* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering)+* Pull in local bindings (#845) - (Sandy Maguire)+* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000)+* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek)+* Fix duplicated completions (#837) - (Vitalii)+* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones)+* Drop 8.4 support (#834) - (wz1000)+* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000)+* Tag unused warning as such (#815) - (Alejandro Serrano)+* Update instructions for stty error in windows (#825) - (Javier Neira)+* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets)+* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets)+* Add completion tests for records. (#804) - (Guru Devanla)+* Restore identifiers missing from hi file (#741) - (maralorn)+* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni)++### 0.4.0 (2020-09-15)+* Fixes for GHC source plugins: dotpreprocessor works now - (srid)+* Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira)+* Extend position mapping with fuzzy ranges (#785) - (wz1000)+* Sort import suggestions (#793) - (Pepe Iborra)+* Save source files with HIE files (#701) - (fendor)+* Fully asynchronous request handling (#767) - (Pepe Iborra)+* Refinement holes (#748) - (Pepe Iborra)+* Fix haddock to markdown conversion (#757) - (George Thomas)+* Expose `getCompletionsLSP` to allow completions in hls (#756) - (wz1000)+* Suggestions for missing imports from local modules (#739) - (Pepe Iborra)+* Dynamically load libm on Linux for each new session (#723) - (Luke Lau)+* Use InitializeParams.rootUri for initial session setup (#713) - (shaurya gupta)+* Show documentation on hover for symbols defined in the same module (#691) - (wz1000)+* Suggest open imports (#740) - (Pepe Iborra)+* module Development.IDE (#724) - (Pepe Iborra)+* Ignore -Werror (#738) - (Pepe Iborra)+* Fix issue #710: fix suggest delete binding  (#728) - (Ray Shih)+* Generate doc file URL via LSP (to fix it for Windows) (#721) - (Nick Dunets)+* Fix `.hie` file location for `.hs-boot` files (#690) - (wz1000)+* Use argsVerbose to determine log level in test mode (#717) - (Ziyang Liu)+* output which cradle files were found (#716) - (Adam Sandberg Eriksson)+* Typecheck entire project on Initial Load and typecheck reverse dependencies of a file on saving (#688) - (wz1000)++### 0.3.0 (2020-09-02)++* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen)+* Add session-loader to hie.yaml (#714) - (Luke Lau)+* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta)+* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau)+* Expose GHC.Compat module (#709) - (Pepe Iborra)+* Move session loading logic into ghcide library (#697) - (Luke Lau)+* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato)+* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer)+* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra)+* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli)+* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra)+* Obtain the GHC libdir at runtime (#696) - (Luke Lau)+* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra)+* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot])+* Update to hie-bios 0.6.1 (#693) - (fendor)+* Backport HIE files to GHC 8.6 (#689) - (wz1000)+* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra)+* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii)+* Use a global namecache to read `.hie` files (#677) - (wz1000)+* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra)+* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra)+* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra)+* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering)+* Code action: add constraint (#653) - (Denis Frezzato)+* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra)+* Delete unused top level binding code action (#657) - (Serhii)+* stack810.yaml: bump (#651) - (Domen Kozar)+* Fix debouncer for 0 delay (#662) - (Pepe Iborra)+* Interface file fixes (#645) - (Pepe Iborra)+* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer)+* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra)+* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra)+* Add a note on differential benchmarks (#647) - (Pepe Iborra)+* Cache a ghc session per file of interest (#630) - (Pepe Iborra)+* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits)+* Report progress when setting up cradle (#644) - (Luke Lau)+* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra)+* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra)+* Performance analysis over time (#629) - (Pepe Iborra)+* More benchmarks (#625) - (Pepe Iborra)+* Canonicalize the locations in the cradle tests (#628) - (Luke Lau)+* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira)+* Fix a bug in getHiFileRule (#623) - (Pepe Iborra)+* ghc initialization error handling (#609) - (Pepe Iborra)+* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra)+* Restore Shake profiling (#621) - (Pepe Iborra)+* Use a better noRange (#612) - (Neil Mitchell)+* Add back a .ghci file (#607) - (Neil Mitchell)+* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell)+* Implement Goto Type Definition (#533) - (Matthew Pickering)+* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra)+* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra)+* Benchmark suite (#590) - (Pepe Iborra)++### 0.2.0 (2020-06-02)++* Multi-component support (thanks @mpickering)+* Support for GHC 8.10 (thanks @sheaf and @chshersh)+* Fix some TH issues (thanks @mpickering)+* Automatically pick up changes to cradle dependencies (e.g. cabal+  files) (thanks @jinwoo)+* Track dependencies when using `qAddDependentFile` (thanks @mpickering)+* Add record fields to document symbols outline (thanks @bubba)+* Fix some space leaks (thanks @mpickering)+* Strip redundant path information from diagnostics (thanks @tek)+* Fix import suggestions for operators (thanks @eddiemundo)+* Significant reductions in memory usage by using interfaces and `.hie` files (thanks+  @pepeiborra)+* Minor improvements to completions+* More comprehensive suggestions for missing imports (thanks @pepeiborra)+* Group imports in document outline (thanks @fendor)+* Upgrade to haskell-lsp-0.22 (thanks @bubba)+* Upgrade to hie-bios 0.5 (thanks @fendor)++### 0.1.0 (2020-02-04)++* Code action for inserting new definitions (see #309).+* Better default GC settings (see #329 and #333).+* Various performance improvements (see #322 and #384).+* Improvements to hover information (see #317 and #338).+* Support GHC 8.8.2 (see #355).+* Include keywords in completions (see #351).+* Fix some issues with aborted requests (see #353).+* Use hie-bios 0.4.0 (see #382).+* Avoid stuck progress reporting (see #400).+* Only show progress notifications after 0.1s (see #392).+* Progress reporting is now in terms of the number of files rather+  than the number of shake rules (see #379).++### 0.0.6 (2020-01-10)++* Fix type in hover information for do-notation and list+  comprehensions (see #243).+* Fix hover and goto-definition for multi-clause definitions (see #252).+* Upgrade to `hie-bios-0.3` (see #257)+* Upgrade to `haskell-lsp-0.19` (see #254)+* Code lenses for missing signatures are displayed even if the warning+  has not been enabled. The warning itself will not be shown if it is+  not enabled. (see #232)+* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific+  workarounds. (see #264)+* Fix some filepath normalization issues. (see #266)+* Fix build with `shake-0.18.4` (see #272)+* Fix hover for type constructors and type classes. (see #267)+* Support custom preprocessors (see #282)+* Add support for code completions (see #227)+* Code action for removing redundant symbols from imports (see #290)+* Support document symbol requests (see #293)+* Show CPP errors as diagnostics (see #296)+* Code action for adding suggested imports (see #295)++### 0.0.5 (2019-12-12)++* Support for GHC plugins (see #192)+* Update to haskell-lsp 0.18 (see #203)+* Initial support for `TemplateHaskell` (see #222)+* Code lenses for missing signatures. These are only shown if+  `-Wmissing-signatures` is enabled. (see #224)+* Fix path normalisation on Windows (see #225)+* Fix flickering of the progress indicator (see #230)++### 0.0.4 (2019-10-20)++* Add a ``--version`` cli option (thanks @jacg)+* Update to use progress reporting as defined in LSP 3.15. The VSCode+  extension has also been updated and should now be making use of+  this.+* Properly declare that we should support code actions. This helps+  with some clients that rely on this information to enable code+  actions (thanks @jacg).+* Fix a race condition caused by sharing the finder cache between+  concurrent compilations.+* Avoid normalizing include dirs. This avoids issues where the same+  file ends up twice in the module graph, e.g., with different casing+  for drive letters.++### 0.0.3 (2019-09-21)
LICENSE view
@@ -1,201 +1,201 @@-                                 Apache License
-                           Version 2.0, January 2004
-                        http://www.apache.org/licenses/
-
-   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
-
-   1. Definitions.
-
-      "License" shall mean the terms and conditions for use, reproduction,
-      and distribution as defined by Sections 1 through 9 of this document.
-
-      "Licensor" shall mean the copyright owner or entity authorized by
-      the copyright owner that is granting the License.
-
-      "Legal Entity" shall mean the union of the acting entity and all
-      other entities that control, are controlled by, or are under common
-      control with that entity. For the purposes of this definition,
-      "control" means (i) the power, direct or indirect, to cause the
-      direction or management of such entity, whether by contract or
-      otherwise, or (ii) ownership of fifty percent (50%) or more of the
-      outstanding shares, or (iii) beneficial ownership of such entity.
-
-      "You" (or "Your") shall mean an individual or Legal Entity
-      exercising permissions granted by this License.
-
-      "Source" form shall mean the preferred form for making modifications,
-      including but not limited to software source code, documentation
-      source, and configuration files.
-
-      "Object" form shall mean any form resulting from mechanical
-      transformation or translation of a Source form, including but
-      not limited to compiled object code, generated documentation,
-      and conversions to other media types.
-
-      "Work" shall mean the work of authorship, whether in Source or
-      Object form, made available under the License, as indicated by a
-      copyright notice that is included in or attached to the work
-      (an example is provided in the Appendix below).
-
-      "Derivative Works" shall mean any work, whether in Source or Object
-      form, that is based on (or derived from) the Work and for which the
-      editorial revisions, annotations, elaborations, or other modifications
-      represent, as a whole, an original work of authorship. For the purposes
-      of this License, Derivative Works shall not include works that remain
-      separable from, or merely link (or bind by name) to the interfaces of,
-      the Work and Derivative Works thereof.
-
-      "Contribution" shall mean any work of authorship, including
-      the original version of the Work and any modifications or additions
-      to that Work or Derivative Works thereof, that is intentionally
-      submitted to Licensor for inclusion in the Work by the copyright owner
-      or by an individual or Legal Entity authorized to submit on behalf of
-      the copyright owner. For the purposes of this definition, "submitted"
-      means any form of electronic, verbal, or written communication sent
-      to the Licensor or its representatives, including but not limited to
-      communication on electronic mailing lists, source code control systems,
-      and issue tracking systems that are managed by, or on behalf of, the
-      Licensor for the purpose of discussing and improving the Work, but
-      excluding communication that is conspicuously marked or otherwise
-      designated in writing by the copyright owner as "Not a Contribution."
-
-      "Contributor" shall mean Licensor and any individual or Legal Entity
-      on behalf of whom a Contribution has been received by Licensor and
-      subsequently incorporated within the Work.
-
-   2. Grant of Copyright License. Subject to the terms and conditions of
-      this License, each Contributor hereby grants to You a perpetual,
-      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
-      copyright license to reproduce, prepare Derivative Works of,
-      publicly display, publicly perform, sublicense, and distribute the
-      Work and such Derivative Works in Source or Object form.
-
-   3. Grant of Patent License. Subject to the terms and conditions of
-      this License, each Contributor hereby grants to You a perpetual,
-      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
-      (except as stated in this section) patent license to make, have made,
-      use, offer to sell, sell, import, and otherwise transfer the Work,
-      where such license applies only to those patent claims licensable
-      by such Contributor that are necessarily infringed by their
-      Contribution(s) alone or by combination of their Contribution(s)
-      with the Work to which such Contribution(s) was submitted. If You
-      institute patent litigation against any entity (including a
-      cross-claim or counterclaim in a lawsuit) alleging that the Work
-      or a Contribution incorporated within the Work constitutes direct
-      or contributory patent infringement, then any patent licenses
-      granted to You under this License for that Work shall terminate
-      as of the date such litigation is filed.
-
-   4. Redistribution. You may reproduce and distribute copies of the
-      Work or Derivative Works thereof in any medium, with or without
-      modifications, and in Source or Object form, provided that You
-      meet the following conditions:
-
-      (a) You must give any other recipients of the Work or
-          Derivative Works a copy of this License; and
-
-      (b) You must cause any modified files to carry prominent notices
-          stating that You changed the files; and
-
-      (c) You must retain, in the Source form of any Derivative Works
-          that You distribute, all copyright, patent, trademark, and
-          attribution notices from the Source form of the Work,
-          excluding those notices that do not pertain to any part of
-          the Derivative Works; and
-
-      (d) If the Work includes a "NOTICE" text file as part of its
-          distribution, then any Derivative Works that You distribute must
-          include a readable copy of the attribution notices contained
-          within such NOTICE file, excluding those notices that do not
-          pertain to any part of the Derivative Works, in at least one
-          of the following places: within a NOTICE text file distributed
-          as part of the Derivative Works; within the Source form or
-          documentation, if provided along with the Derivative Works; or,
-          within a display generated by the Derivative Works, if and
-          wherever such third-party notices normally appear. The contents
-          of the NOTICE file are for informational purposes only and
-          do not modify the License. You may add Your own attribution
-          notices within Derivative Works that You distribute, alongside
-          or as an addendum to the NOTICE text from the Work, provided
-          that such additional attribution notices cannot be construed
-          as modifying the License.
-
-      You may add Your own copyright statement to Your modifications and
-      may provide additional or different license terms and conditions
-      for use, reproduction, or distribution of Your modifications, or
-      for any such Derivative Works as a whole, provided Your use,
-      reproduction, and distribution of the Work otherwise complies with
-      the conditions stated in this License.
-
-   5. Submission of Contributions. Unless You explicitly state otherwise,
-      any Contribution intentionally submitted for inclusion in the Work
-      by You to the Licensor shall be under the terms and conditions of
-      this License, without any additional terms or conditions.
-      Notwithstanding the above, nothing herein shall supersede or modify
-      the terms of any separate license agreement you may have executed
-      with Licensor regarding such Contributions.
-
-   6. Trademarks. This License does not grant permission to use the trade
-      names, trademarks, service marks, or product names of the Licensor,
-      except as required for reasonable and customary use in describing the
-      origin of the Work and reproducing the content of the NOTICE file.
-
-   7. Disclaimer of Warranty. Unless required by applicable law or
-      agreed to in writing, Licensor provides the Work (and each
-      Contributor provides its Contributions) on an "AS IS" BASIS,
-      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
-      implied, including, without limitation, any warranties or conditions
-      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
-      PARTICULAR PURPOSE. You are solely responsible for determining the
-      appropriateness of using or redistributing the Work and assume any
-      risks associated with Your exercise of permissions under this License.
-
-   8. Limitation of Liability. In no event and under no legal theory,
-      whether in tort (including negligence), contract, or otherwise,
-      unless required by applicable law (such as deliberate and grossly
-      negligent acts) or agreed to in writing, shall any Contributor be
-      liable to You for damages, including any direct, indirect, special,
-      incidental, or consequential damages of any character arising as a
-      result of this License or out of the use or inability to use the
-      Work (including but not limited to damages for loss of goodwill,
-      work stoppage, computer failure or malfunction, or any and all
-      other commercial damages or losses), even if such Contributor
-      has been advised of the possibility of such damages.
-
-   9. Accepting Warranty or Additional Liability. While redistributing
-      the Work or Derivative Works thereof, You may choose to offer,
-      and charge a fee for, acceptance of support, warranty, indemnity,
-      or other liability obligations and/or rights consistent with this
-      License. However, in accepting such obligations, You may act only
-      on Your own behalf and on Your sole responsibility, not on behalf
-      of any other Contributor, and only if You agree to indemnify,
-      defend, and hold each Contributor harmless for any liability
-      incurred by, or claims asserted against, such Contributor by reason
-      of your accepting any such warranty or additional liability.
-
-   END OF TERMS AND CONDITIONS
-
-   APPENDIX: How to apply the Apache License to your work.
-
-      To apply the Apache License to your work, attach the following
-      boilerplate notice, with the fields enclosed by brackets "[]"
-      replaced with your own identifying information. (Don't include
-      the brackets!)  The text should be enclosed in the appropriate
-      comment syntax for the file format. We also recommend that a
-      file or class name and description of purpose be included on the
-      same "printed page" as the copyright notice for easier
-      identification within third-party archives.
-
-   Copyright 2019 Digital Asset (Switzerland) GmbH and/or its affiliates
-
-   Licensed under the Apache License, Version 2.0 (the "License");
-   you may not use this file except in compliance with the License.
-   You may obtain a copy of the License at
-
-       http://www.apache.org/licenses/LICENSE-2.0
-
-   Unless required by applicable law or agreed to in writing, software
-   distributed under the License is distributed on an "AS IS" BASIS,
-   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-   See the License for the specific language governing permissions and
-   limitations under the License.
+                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2019 Digital Asset (Switzerland) GmbH and/or its affiliates++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
README.md view
@@ -1,358 +1,358 @@-# `ghcide` - A library for building Haskell IDE tooling
-
-Our vision is that you should build an IDE by combining:
-
-![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png)
-
-* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on;
-* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages;
-* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want;
-* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server;
-* An LSP client for your editor.
-
-There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide).
-
-## Features
-
-`ghcide` already exports the following features via the lsp protocol:
-
-| Feature | LSP name |
-| - | - |
-| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics |
-| Go to definition in local package | definition  |
-| Display type and source module of values | hover |
-| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions  | codeAction (quickfix) |
-
-
-## Limitations to Multi-Component support
-
-`ghcide` supports loading multiple components into the same session so that
-features such as go-to definition work across components. However, there are
-some limitations to this.
-
-1. You will get much better results currently manually specifying the hie.yaml file.
-Until tools like cabal and stack provide the right interface to support multi-component
-projects, it is always advised to specify explicitly how your project partitions.
-2. Cross-component features only work if you have loaded at least one file
-from each component.
-3. There is a known issue where if you have three components, such that A depends on B which depends on C
-then if you load A and C into the session but not B then under certain situations you
-can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for
-a simple reproduction of the bug.
-
-## Using it
-
-`ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)).
-
- [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page.
-
-
-The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes.
-
-### Install `ghcide`
-
-#### With Nix
-
-Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.
-
-1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via
-   ```
-   nix-env -iA haskellPackages.ghcide
-   ```
-   or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.
-   Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.
-
-2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)
-   which provides a `ghcide` via the `haskell.nix` infrastructure.
-
-#### With Cabal or Stack
-
-First install the `ghcide` binary using `stack` or `cabal`, e.g.
-
-1. `git clone https://github.com/haskell/ghcide.git`
-2. `cd ghcide`
-3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`)
-
-It's important that `ghcide` is compiled with the same compiler you use to build your projects.
-
-### Test `ghcide`
-
-Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end:
-
-```console
-Files that failed:
- * .\model\Main.hs
- * .\model\Model.hs
- * .\model\Test.hs
- * .\model\Util.hs
- * .\output\docs\Main.hs
- * .\output\docs\Part_Architecture_md.hs
-Completed (152 worked, 6 failed)
-```
-
-Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake.
-
-The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project.
-
-If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.
-
-### Optimal project setup
-
-`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
-
-### Configuration
-
-`ghcide` accepts the following lsp configuration options:
-
-```typescript
-{
-  // When to check the dependents of a module
-  // AlwaysCheck means retypechecking them on every change
-  // CheckOnSave means dependent/parent modules will only be checked when you save
-  // "CheckOnSaveAndClose" by default
-  checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | ,
-  // Whether to check the entire project on initial load
-  // true by default
-  checkProject : boolean
-
-}
-```
-
-### Using with VS Code
-
-The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide.
-
-### Using with Atom
-
-You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.
-
-### Using with Sublime Text
-
-* Install [LSP](https://packagecontrol.io/packages/LSP)
-* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings
-```
-{
-  "clients":
-  {
-    "ghcide":
-    {
-      "enabled"   : true,
-      "languageId": "haskell",
-      "command"   : ["ghcide", "--lsp"],
-      "scopes"    : ["source.haskell"],
-      "syntaxes"  : ["Packages/Haskell/Haskell.sublime-syntax"]
-    }
-  }
-}
-```
-
-### Using with Emacs
-
-If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package).
-
-Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server:
-
-+ `lsp-ui`
-+ `eglot` (requires Emacs 26.1+)
-
-In each case, you can enable support by adding the shown lines to your `.emacs`:
-
-#### lsp-ui
-
-```elisp
-;; LSP
-(use-package flycheck
-  :ensure t
-  :init
-  (global-flycheck-mode t))
-(use-package yasnippet
-  :ensure t)
-(use-package lsp-mode
-  :ensure t
-  :hook (haskell-mode . lsp)
-  :commands lsp)
-(use-package lsp-ui
-  :ensure t
-  :commands lsp-ui-mode)
-(use-package lsp-haskell
- :ensure t
- :config
- (setq lsp-haskell-process-path-hie "ghcide")
- (setq lsp-haskell-process-args-hie '())
- ;; Comment/uncomment this line to see interactions between lsp client/server.
- ;;(setq lsp-log-io t)
-)
-```
-
-#### eglot
-
-````elisp
-(use-package eglot
-  :ensure t
-  :config
-  (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp"))))
-````
-
-### Using with Vim/Neovim
-
-#### LanguageClient-neovim
-Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)
-
-Add this to your vim config:
-```vim
-let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml']
-let g:LanguageClient_serverCommands = {
-    \ 'rust': ['rls'],
-    \ 'haskell': ['ghcide', '--lsp'],
-    \ }
-```
-
-Refer to `:he LanguageClient` for more details on usage and configuration.
-
-#### vim-lsp
-Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp).
-
-Add this to your vim config:
-
-```vim
-au User lsp_setup call lsp#register_server({
-    \ 'name': 'ghcide',
-    \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']},
-    \ 'whitelist': ['haskell'],
-    \ })
-```
-
-To verify it works move your cursor over a symbol and run `:LspHover`.
-
-### coc.nvim
-
-Install [coc.nvim](https://github.com/neoclide/coc.nvim)
-
-Add this to your coc-settings.json (which you can edit with :CocConfig):
-
-```json
-{
-  "languageserver": {
-    "haskell": {
-      "command": "ghcide",
-      "args": [
-        "--lsp"
-      ],
-      "rootPatterns": [
-        ".stack.yaml",
-        ".hie-bios",
-        "BUILD.bazel",
-        "cabal.config",
-        "package.yaml"
-      ],
-      "filetypes": [
-        "hs",
-        "lhs",
-        "haskell"
-      ]
-    }
-  }
-}
-```
-
-Here's a nice article on setting up neovim and coc: [Vim and Haskell in
-2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)
-
-Here is a Docker container that pins down the build and configuration for
-Neovim and ghcide on a minimal Debian 10 base system:
-[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).
-
-### SpaceVim
-
-In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`:
-
-```toml
-[[layers]]
-  name = 'autocomplete'
-  auto-completion-return-key-behavior = "complete"
-  auto-completion-tab-key-behavior = "smart"
-  [options]
-    autocomplete_method = "coc"
-```
-
-Add this to your coc-settings.json (which you can edit with :CocConfig):
-
-```json
-{
-  "languageserver": {
-    "haskell": {
-      "command": "ghcide",
-      "args": [
-        "--lsp"
-      ],
-      "rootPatterns": [
-        ".stack.yaml",
-        ".hie-bios",
-        "BUILD.bazel",
-        "cabal.config",
-        "package.yaml"
-      ],
-      "filetypes": [
-        "hs",
-        "lhs",
-        "haskell"
-      ]
-    }
-  }
-}
-```
-
-This example above describes a setup in which `ghcide` is installed
-using `stack install ghcide` within a project.
-
-### Using with Kakoune
-
-Install [kak-lsp](https://github.com/ul/kak-lsp).
-
-Change `kak-lsp.toml` to include this:
-
-```toml
-[language.haskell]
-filetypes = ["haskell"]
-roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]
-command = "ghcide"
-args = ["--lsp"]
-```
-
-## Hacking on ghcide
-
-To build and work on `ghcide` itself, you should use cabal, e.g.,
-running `cabal test` will execute the test suite. You can use `stack test` too, but
-note that some tests will fail, and none of the maintainers are currently using `stack`.
-
-If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`.
-
-If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.
-
-If you are chasing down test failures, you can use the tasty-rerun feature by running tests as
-
-    cabal test --test-options"--rerun"
-
-This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.
-See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.
-
-If you are touching performance sensitive code, take the time to run a differential
-benchmark between HEAD and master using the benchHist script. This assumes that
-"master" points to the upstream master.
-
-Run the benchmarks with `cabal bench`.
-
-It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.
-
-More details in [bench/README](bench/README.md)
-
-
-## History and relationship to other Haskell IDE's
-
-The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).
-
-The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020.
-
-The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files.
-
-The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/).
+# `ghcide` - A library for building Haskell IDE tooling++Our vision is that you should build an IDE by combining:++![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png)++* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on;+* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages;+* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want;+* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server;+* An LSP client for your editor.++There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide).++## Features++`ghcide` already exports the following features via the lsp protocol:++| Feature | LSP name |+| - | - |+| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics |+| Go to definition in local package | definition  |+| Display type and source module of values | hover |+| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions  | codeAction (quickfix) |+++## Limitations to Multi-Component support++`ghcide` supports loading multiple components into the same session so that+features such as go-to definition work across components. However, there are+some limitations to this.++1. You will get much better results currently manually specifying the hie.yaml file.+Until tools like cabal and stack provide the right interface to support multi-component+projects, it is always advised to specify explicitly how your project partitions.+2. Cross-component features only work if you have loaded at least one file+from each component.+3. There is a known issue where if you have three components, such that A depends on B which depends on C+then if you load A and C into the session but not B then under certain situations you+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for+a simple reproduction of the bug.++## Using it++`ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)).++ [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page.+++The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes.++### Install `ghcide`++#### With Nix++Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.++1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via+   ```+   nix-env -iA haskellPackages.ghcide+   ```+   or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.+   Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.++2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)+   which provides a `ghcide` via the `haskell.nix` infrastructure.++#### With Cabal or Stack++First install the `ghcide` binary using `stack` or `cabal`, e.g.++1. `git clone https://github.com/haskell/ghcide.git`+2. `cd ghcide`+3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`)++It's important that `ghcide` is compiled with the same compiler you use to build your projects.++### Test `ghcide`++Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end:++```console+Files that failed:+ * .\model\Main.hs+ * .\model\Model.hs+ * .\model\Test.hs+ * .\model\Util.hs+ * .\output\docs\Main.hs+ * .\output\docs\Part_Architecture_md.hs+Completed (152 worked, 6 failed)+```++Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake.++The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project.++If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.++### Optimal project setup++`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.++### Configuration++`ghcide` accepts the following lsp configuration options:++```typescript+{+  // When to check the dependents of a module+  // AlwaysCheck means retypechecking them on every change+  // CheckOnSave means dependent/parent modules will only be checked when you save+  // "CheckOnSaveAndClose" by default+  checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | ,+  // Whether to check the entire project on initial load+  // true by default+  checkProject : boolean++}+```++### Using with VS Code++The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide.++### Using with Atom++You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.++### Using with Sublime Text++* Install [LSP](https://packagecontrol.io/packages/LSP)+* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings+```+{+  "clients":+  {+    "ghcide":+    {+      "enabled"   : true,+      "languageId": "haskell",+      "command"   : ["ghcide", "--lsp"],+      "scopes"    : ["source.haskell"],+      "syntaxes"  : ["Packages/Haskell/Haskell.sublime-syntax"]+    }+  }+}+```++### Using with Emacs++If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package).++Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server:+++ `lsp-ui`++ `eglot` (requires Emacs 26.1+)++In each case, you can enable support by adding the shown lines to your `.emacs`:++#### lsp-ui++```elisp+;; LSP+(use-package flycheck+  :ensure t+  :init+  (global-flycheck-mode t))+(use-package yasnippet+  :ensure t)+(use-package lsp-mode+  :ensure t+  :hook (haskell-mode . lsp)+  :commands lsp)+(use-package lsp-ui+  :ensure t+  :commands lsp-ui-mode)+(use-package lsp-haskell+ :ensure t+ :config+ (setq lsp-haskell-process-path-hie "ghcide")+ (setq lsp-haskell-process-args-hie '())+ ;; Comment/uncomment this line to see interactions between lsp client/server.+ ;;(setq lsp-log-io t)+)+```++#### eglot++````elisp+(use-package eglot+  :ensure t+  :config+  (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp"))))+````++### Using with Vim/Neovim++#### LanguageClient-neovim+Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)++Add this to your vim config:+```vim+let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml']+let g:LanguageClient_serverCommands = {+    \ 'rust': ['rls'],+    \ 'haskell': ['ghcide', '--lsp'],+    \ }+```++Refer to `:he LanguageClient` for more details on usage and configuration.++#### vim-lsp+Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp).++Add this to your vim config:++```vim+au User lsp_setup call lsp#register_server({+    \ 'name': 'ghcide',+    \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']},+    \ 'whitelist': ['haskell'],+    \ })+```++To verify it works move your cursor over a symbol and run `:LspHover`.++### coc.nvim++Install [coc.nvim](https://github.com/neoclide/coc.nvim)++Add this to your coc-settings.json (which you can edit with :CocConfig):++```json+{+  "languageserver": {+    "haskell": {+      "command": "ghcide",+      "args": [+        "--lsp"+      ],+      "rootPatterns": [+        ".stack.yaml",+        ".hie-bios",+        "BUILD.bazel",+        "cabal.config",+        "package.yaml"+      ],+      "filetypes": [+        "hs",+        "lhs",+        "haskell"+      ]+    }+  }+}+```++Here's a nice article on setting up neovim and coc: [Vim and Haskell in+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)++Here is a Docker container that pins down the build and configuration for+Neovim and ghcide on a minimal Debian 10 base system:+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).++### SpaceVim++In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`:++```toml+[[layers]]+  name = 'autocomplete'+  auto-completion-return-key-behavior = "complete"+  auto-completion-tab-key-behavior = "smart"+  [options]+    autocomplete_method = "coc"+```++Add this to your coc-settings.json (which you can edit with :CocConfig):++```json+{+  "languageserver": {+    "haskell": {+      "command": "ghcide",+      "args": [+        "--lsp"+      ],+      "rootPatterns": [+        ".stack.yaml",+        ".hie-bios",+        "BUILD.bazel",+        "cabal.config",+        "package.yaml"+      ],+      "filetypes": [+        "hs",+        "lhs",+        "haskell"+      ]+    }+  }+}+```++This example above describes a setup in which `ghcide` is installed+using `stack install ghcide` within a project.++### Using with Kakoune++Install [kak-lsp](https://github.com/ul/kak-lsp).++Change `kak-lsp.toml` to include this:++```toml+[language.haskell]+filetypes = ["haskell"]+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]+command = "ghcide"+args = ["--lsp"]+```++## Hacking on ghcide++To build and work on `ghcide` itself, you should use cabal, e.g.,+running `cabal test` will execute the test suite. You can use `stack test` too, but+note that some tests will fail, and none of the maintainers are currently using `stack`.++If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`.++If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.++If you are chasing down test failures, you can use the tasty-rerun feature by running tests as++    cabal test --test-options"--rerun"++This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.+See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.++If you are touching performance sensitive code, take the time to run a differential+benchmark between HEAD and master using the benchHist script. This assumes that+"master" points to the upstream master.++Run the benchmarks with `cabal bench`.++It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module.++More details in [bench/README](bench/README.md)+++## History and relationship to other Haskell IDE's++The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).++The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020.++The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files.++The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/).
bench/exe/Main.hs view
@@ -1,50 +1,59 @@-{- An automated benchmark built around the simple experiment described in:
-
-  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
-
-  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
-  loads the module 'Distribution.Simple'. The rationale for this choice is:
-
-    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
-    - It has very few dependencies, and all are already needed to build ghcide
-    - Distribution.Simple has 235 transitive module dependencies, so non trivial
-
-  The experiments are sequences of lsp commands scripted using lsp-test.
-  A more refined approach would be to record and replay real IDE interactions,
-  once the replay functionality is available in lsp-test.
-  A more declarative approach would be to reuse ide-debug-driver:
-
-  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
-
-  The result of an experiment is a total duration in seconds after a preset
-  number of iterations. There is ample room for improvement:
-     - Statistical analysis to detect outliers and auto infer the number of iterations needed
-     - GC stats analysis (currently -S is printed as part of the experiment)
-     - Analyisis of performance over the commit history of the project
-
-  How to run:
-     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`
-     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`
-
-  Note that the package database influences the response times of certain actions,
-  e.g. code actions, and therefore the two methods above do not necessarily
-  produce the same results.
-
- -}
-
-{-# LANGUAGE ImplicitParams #-}
-
-import Control.Exception.Safe
-import Experiments
-import Options.Applicative
-
-main :: IO ()
-main = do
-  config <- execParser $ info (configP <**> helper) fullDesc
-  let ?config = config
-
-  output "starting test"
-
-  SetupResult{..} <- setup
-
-  runBenchmarks experiments `finally` cleanUp
+{- An automated benchmark built around the simple experiment described in:++  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html++  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and+  loads the module 'Distribution.Simple'. The rationale for this choice is:++    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`+    - It has very few dependencies, and all are already needed to build ghcide+    - Distribution.Simple has 235 transitive module dependencies, so non trivial++  The experiments are sequences of lsp commands scripted using lsp-test.+  A more refined approach would be to record and replay real IDE interactions,+  once the replay functionality is available in lsp-test.+  A more declarative approach would be to reuse ide-debug-driver:++  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md++  The result of an experiment is a total duration in seconds after a preset+  number of iterations. There is ample room for improvement:+     - Statistical analysis to detect outliers and auto infer the number of iterations needed+     - GC stats analysis (currently -S is printed as part of the experiment)+     - Analyisis of performance over the commit history of the project++  How to run:+     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`+     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`++  Note that the package database influences the response times of certain actions,+  e.g. code actions, and therefore the two methods above do not necessarily+  produce the same results.++ -}++{-# LANGUAGE ImplicitParams #-}++import Control.Exception.Safe+import Experiments+import Options.Applicative+import System.IO+import           Control.Monad++optsP :: Parser (Config, Bool)+optsP = (,) <$> configP <*> switch (long "no-clean")++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc+  let ?config = config++  hPrint stderr config++  output "starting test"++  SetupResult{..} <- setup++  runBenchmarks experiments `finally` unless noClean cleanUp
bench/hist/Main.hs view
@@ -1,147 +1,153 @@-{-  Bench history
-
-    A Shake script to analyze the performance of ghcide over the git history of the project
-
-    Driven by a config file `bench/config.yaml` containing the list of Git references to analyze.
-
-    Builds each one of them and executes a set of experiments using the ghcide-bench suite.
-
-    The results of the benchmarks and the analysis are recorded in the file
-    system with the following structure:
-
-    bench-results
-    ├── <git-reference>
-    │   ├── ghc.path                          - path to ghc used to build the binary
-    │   ├── ghcide                            - binary for this version
-    ├─ <example>
-    │   ├── results.csv                           - aggregated results for all the versions
-    │   └── <git-reference>
-    │       ├── <experiment>.benchmark-gcStats    - RTS -s output
-    │       ├── <experiment>.csv                  - stats for the experiment
-    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time
-    │       ├── <experiment>.diff.svg             - idem, including the previous version
-    │       ├── <experiment>.log                  - ghcide-bench output
-    │       └── results.csv                       - results of all the experiments for the example
-    ├── results.csv        - aggregated results of all the experiments and versions
-    └── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions
-
-   For diff graphs, the "previous version" is the preceding entry in the list of versions
-   in the config file. A possible improvement is to obtain this info via `git rev-list`.
-
-   To execute the script:
-
-   > cabal/stack bench
-
-   To build a specific analysis, enumerate the desired file artifacts
-
-   > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
-   > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
-
- -}
-{-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE DerivingStrategies#-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# OPTIONS -Wno-orphans #-}
-
-import Data.Foldable (find)
-import Data.Yaml (FromJSON (..), decodeFileThrow)
-import Development.Benchmark.Rules
-import Development.Shake
-import Experiments.Types (Example, exampleToOptions)
-import qualified Experiments.Types as E
-import GHC.Generics (Generic)
-import Numeric.Natural (Natural)
-
-
-config :: FilePath
-config = "bench/config.yaml"
-
--- | Read the config without dependency
-readConfigIO :: FilePath -> IO (Config BuildSystem)
-readConfigIO = decodeFileThrow
-
-instance IsExample Example where getExampleName = E.getExampleName
-type instance RuleResult GetExample = Maybe Example
-type instance RuleResult GetExamples = [Example]
-
-main :: IO ()
-main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
-  createBuildSystem $ \resource -> do
-      configStatic <- liftIO $ readConfigIO config
-      let build = outputFolder configStatic
-      buildRules build ghcideBuildRules
-      benchRules build resource (MkBenchRules (benchGhcide $ samples configStatic) "ghcide")
-      csvRules build
-      svgRules build
-      action $ allTargets build
-
-ghcideBuildRules :: MkBuildRules BuildSystem
-ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide
-
---------------------------------------------------------------------------------
-
-data Config buildSystem = Config
-  { experiments :: [Unescaped String],
-    examples :: [Example],
-    samples :: Natural,
-    versions :: [GitCommit],
-    -- | Output folder ('foo' works, 'foo/bar' does not)
-    outputFolder :: String,
-    buildTool :: buildSystem
-  }
-  deriving (Generic, Show)
-  deriving anyclass (FromJSON)
-
-createBuildSystem :: (Resource -> Rules a) -> Rules a
-createBuildSystem userRules = do
-  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
-
-  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
-  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
-  _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config
-  _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
-  _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config
-
-  benchResource <- newResource "ghcide-bench" 1
-
-  userRules benchResource
-
---------------------------------------------------------------------------------
-
-buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()
-buildGhcide Cabal args out = do
-    command_ args "cabal"
-        ["install"
-        ,"exe:ghcide"
-        ,"--installdir=" ++ out
-        ,"--install-method=copy"
-        ,"--overwrite-policy=always"
-        ,"--ghc-options=-rtsopts"
-        ]
-
-buildGhcide Stack args out =
-    command_ args "stack"
-        ["--local-bin-path=" <> out
-        ,"build"
-        ,"ghcide:ghcide"
-        ,"--copy-bins"
-        ,"--ghc-options=-rtsopts"
-        ]
-
-benchGhcide
-  :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()
-benchGhcide samples buildSystem args BenchProject{..} =
-  command_ args "ghcide-bench" $
-    [ "--timeout=3000",
-        "-v",
-        "--samples=" <> show samples,
-        "--csv="     <> outcsv,
-        "--ghcide="  <> exePath,
-        "--select",
-        unescaped (unescapeExperiment experiment)
-    ] ++
-    exampleToOptions example ++
-    [ "--stack" | Stack == buildSystem
-    ] ++
-    exeExtraArgs
-
+{-  Bench history++    A Shake script to analyze the performance of ghcide over the git history of the project++    Driven by a config file `bench/config.yaml` containing the list of Git references to analyze.++    Builds each one of them and executes a set of experiments using the ghcide-bench suite.++    The results of the benchmarks and the analysis are recorded in the file+    system with the following structure:++    bench-results+    ├── <git-reference>+    │   ├── ghc.path                          - path to ghc used to build the binary+    │   ├── ghcide                            - binary for this version+    ├─ <example>+    │   ├── results.csv                           - aggregated results for all the versions+    │   └── <git-reference>+    │       ├── <experiment>.benchmark-gcStats    - RTS -s output+    │       ├── <experiment>.csv                  - stats for the experiment+    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time+    │       ├── <experiment>.diff.svg             - idem, including the previous version+    │       ├── <experiment>.log                  - ghcide-bench output+    │       └── results.csv                       - results of all the experiments for the example+    ├── results.csv        - aggregated results of all the experiments and versions+    └── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions++   For diff graphs, the "previous version" is the preceding entry in the list of versions+   in the config file. A possible improvement is to obtain this info via `git rev-list`.++   To execute the script:++   > cabal/stack bench++   To build a specific analysis, enumerate the desired file artifacts++   > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"+   > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"++ -}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DerivingStrategies#-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -Wno-orphans #-}++import Data.Foldable (find)+import Data.Yaml (FromJSON (..), decodeFileThrow)+import Development.Benchmark.Rules+import Development.Shake+import Experiments.Types (Example, exampleToOptions)+import qualified Experiments.Types as E+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Development.Shake.Classes+++config :: FilePath+config = "bench/config.yaml"++-- | Read the config without dependency+readConfigIO :: FilePath -> IO (Config BuildSystem)+readConfigIO = decodeFileThrow++instance IsExample Example where getExampleName = E.getExampleName+type instance RuleResult GetExample = Maybe Example+type instance RuleResult GetExamples = [Example]++main :: IO ()+main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do+  createBuildSystem $ \resource -> do+      configStatic <- liftIO $ readConfigIO config+      let build = outputFolder configStatic+      buildRules build ghcideBuildRules+      benchRules build resource (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide")+      csvRules build+      svgRules build+      action $ allTargets build++ghcideBuildRules :: MkBuildRules BuildSystem+ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide++--------------------------------------------------------------------------------++data Config buildSystem = Config+  { experiments :: [Unescaped String],+    examples :: [Example],+    samples :: Natural,+    versions :: [GitCommit],+    -- | Output folder ('foo' works, 'foo/bar' does not)+    outputFolder :: String,+    buildTool :: buildSystem+  }+  deriving (Generic, Show)+  deriving anyclass (FromJSON)++createBuildSystem :: (Resource -> Rules a) -> Rules a+createBuildSystem userRules = do+  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)++  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config+  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config+  _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config+  _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config+  _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config+  _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config++  benchResource <- newResource "ghcide-bench" 1++  userRules benchResource++newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)+type instance RuleResult GetSamples = Natural++--------------------------------------------------------------------------------++buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()+buildGhcide Cabal args out = do+    command_ args "cabal"+        ["install"+        ,"exe:ghcide"+        ,"--installdir=" ++ out+        ,"--install-method=copy"+        ,"--overwrite-policy=always"+        ,"--ghc-options=-rtsopts"+        ]++buildGhcide Stack args out =+    command_ args "stack"+        ["--local-bin-path=" <> out+        ,"build"+        ,"ghcide:ghcide"+        ,"--copy-bins"+        ,"--ghc-options=-rtsopts"+        ]++benchGhcide+  :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()+benchGhcide samples buildSystem args BenchProject{..} = do+  command_ args "ghcide-bench" $+    [ "--timeout=3000",+      "--no-clean",+        "-v",+        "--samples=" <> show samples,+        "--csv="     <> outcsv,+        "--ghcide="  <> exePath,+        "--select",+        unescaped (unescapeExperiment experiment)+    ] +++    exampleToOptions example +++    [ "--stack" | Stack == buildSystem+    ] +++    exeExtraArgs+
bench/lib/Experiments.hs view
@@ -1,484 +1,531 @@-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-
-module Experiments
-( Bench(..)
-, BenchRun(..)
-, Config(..)
-, Verbosity(..)
-, CabalStack(..)
-, SetupResult(..)
-, Example(..)
-, experiments
-, configP
-, defConfig
-, output
-, setup
-, runBench
-, exampleToOptions
-) where
-import Control.Applicative.Combinators (skipManyTill)
-import Control.Concurrent
-import Control.Exception.Safe
-import Control.Monad.Extra
-import Control.Monad.IO.Class
-import Data.Aeson (Value(Null))
-import Data.Char (isDigit)
-import Data.List
-import Data.Maybe
-import qualified Data.Text as T
-import Data.Version
-import Development.IDE.Plugin.Test
-import Experiments.Types
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Capabilities
-import Numeric.Natural
-import Options.Applicative
-import System.Directory
-import System.Environment.Blank (getEnv)
-import System.FilePath ((</>), (<.>))
-import System.Process
-import System.Time.Extra
-import Text.ParserCombinators.ReadP (readP_to_S)
-
-hygienicEdit :: (?hygienicP :: Position) => TextDocumentContentChangeEvent
-hygienicEdit =
-    TextDocumentContentChangeEvent
-    { _range = Just (Range ?hygienicP ?hygienicP),
-        _rangeLength = Nothing,
-        _text = " "
-    }
-
-breakingEdit :: (?identifierP :: Position) => TextDocumentContentChangeEvent
-breakingEdit =
-    TextDocumentContentChangeEvent
-    { _range = Just (Range ?identifierP ?identifierP),
-        _rangeLength = Nothing,
-        _text = "a"
-    }
-
--- | Experiments have access to these special positions:
--- - hygienicP points to a string in the target file, convenient for hygienic edits
--- - identifierP points to the middle of an identifier, convenient for goto-def, hover and completions
-type HasPositions = (?hygienicP :: Position, ?identifierP :: Position)
-
-experiments :: [Bench]
-experiments =
-    [ ---------------------------------------------------------------------------------------
-      bench "hover" 10 $ \doc ->
-        isJust <$> getHover doc ?identifierP,
-      ---------------------------------------------------------------------------------------
-      bench "edit" 10 $ \doc -> do
-        changeDoc doc [hygienicEdit]
-        waitForProgressDone
-        return True,
-      ---------------------------------------------------------------------------------------
-      bench "hover after edit" 10 $ \doc -> do
-        changeDoc doc [hygienicEdit]
-        isJust <$> getHover doc ?identifierP,
-      ---------------------------------------------------------------------------------------
-      bench "getDefinition" 10 $ \doc ->
-        not . null <$> getDefinitions doc ?identifierP,
-      ---------------------------------------------------------------------------------------
-      bench "documentSymbols" 100 $
-        fmap (either (not . null) (not . null)) . getDocumentSymbols,
-      ---------------------------------------------------------------------------------------
-      bench "documentSymbols after edit" 100 $ \doc -> do
-        changeDoc doc [hygienicEdit]
-        either (not . null) (not . null) <$> getDocumentSymbols doc,
-      ---------------------------------------------------------------------------------------
-      bench "completions after edit" 10 $ \doc -> do
-        changeDoc doc [hygienicEdit]
-        not . null <$> getCompletions doc ?identifierP,
-      ---------------------------------------------------------------------------------------
-      benchWithSetup
-        "code actions"
-        10
-        ( \doc -> do
-            changeDoc doc [breakingEdit]
-            waitForProgressDone
-            return ?identifierP
-        )
-        ( \p doc -> do
-            not . null <$> getCodeActions doc (Range p p)
-        ),
-      ---------------------------------------------------------------------------------------
-      benchWithSetup
-        "code actions after edit"
-        10
-        ( \doc -> do
-            changeDoc doc [breakingEdit]
-            return ?identifierP
-        )
-        ( \p doc -> do
-            changeDoc doc [hygienicEdit]
-            waitForProgressDone
-            -- NOTE ghcide used to clear and reinstall the diagnostics here
-            -- new versions no longer do, but keep this logic around
-            -- to benchmark old versions sucessfully
-            diags <- getCurrentDiagnostics doc
-            when (null diags) $
-              whileM (null <$> waitForDiagnostics)
-            not . null <$> getCodeActions doc (Range p p)
-        )
-    ]
-
----------------------------------------------------------------------------------------------
-
-exampleModulePath :: HasConfig => FilePath
-exampleModulePath = exampleModule (example ?config)
-
-examplesPath :: FilePath
-examplesPath = "bench/example"
-
-defConfig :: Config
-Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []
-
-quiet, verbose :: Config -> Bool
-verbose = (== All) . verbosity
-quiet   = (== Quiet) . verbosity
-
-type HasConfig = (?config :: Config)
-
-configP :: Parser Config
-configP =
-  Config
-    <$> (flag' All (short 'v' <> long "verbose")
-         <|> flag' Quiet (short 'q' <> long "quiet")
-         <|> pure Normal
-        )
-    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
-    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))
-    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)
-    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")
-    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))
-    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))
-    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
-    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
-    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
-    <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal")
-               <*> moduleOption
-               <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0]))
-         <|>
-          UsePackage <$> strOption (long "example-path")
-                     <*> moduleOption
-         )
-  where
-      moduleOption = strOption (long "example-module" <> metavar "PATH" <> value "Distribution/Simple.hs")
-
-versionP :: ReadM Version
-versionP = maybeReader $ extract . readP_to_S parseVersion
-  where
-      extract parses = listToMaybe [ res | (res,"") <- parses]
-
-output :: (MonadIO m, HasConfig) => String -> m ()
-output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn
-
----------------------------------------------------------------------------------------
-
-type Experiment = TextDocumentIdentifier -> Session Bool
-
-data Bench = forall setup.
-  Bench
-  { name :: !String,
-    enabled :: !Bool,
-    samples :: !Natural,
-    benchSetup :: HasPositions => TextDocumentIdentifier -> Session setup,
-    experiment :: HasPositions => setup -> Experiment
-  }
-
-select :: HasConfig => Bench -> Bool
-select Bench {name, enabled} =
-  enabled && (null mm || name `elem` mm)
-  where
-    mm = matches ?config
-
-benchWithSetup ::
-  String ->
-  Natural ->
-  (HasPositions => TextDocumentIdentifier -> Session p) ->
-  (HasPositions => p -> Experiment) ->
-  Bench
-benchWithSetup name samples benchSetup experiment = Bench {..}
-  where
-    enabled = True
-
-bench :: String -> Natural -> (HasPositions => Experiment) -> Bench
-bench name defSamples userExperiment =
-  benchWithSetup name defSamples (const $ pure ()) experiment
-  where
-    experiment () = userExperiment
-
-runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()
-runBenchmarksFun dir allBenchmarks = do
-  let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }
-                   | b <- allBenchmarks
-                   , select b ]
-
-  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->
-      createDirectoryIfMissing True eventlogDir
-
-  results <- forM benchmarks $ \b@Bench{name} ->
-                let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir
-                in (b,) <$> runBench run b
-
-  -- output raw data as CSV
-  let headers =
-        [ "name"
-        , "success"
-        , "samples"
-        , "startup"
-        , "setup"
-        , "userTime"
-        , "delayedTime"
-        , "totalTime"
-        , "maxResidency"
-        , "allocatedBytes"]
-      rows =
-        [ [ name,
-            show success,
-            show samples,
-            show startup,
-            show runSetup',
-            show userWaits,
-            show delayedWork,
-            show runExperiment,
-            show maxResidency,
-            show allocations
-          ]
-          | (Bench {name, samples}, BenchRun {..}) <- results,
-            let runSetup' = if runSetup < 0.01 then 0 else runSetup
-        ]
-      csv = unlines $ map (intercalate ", ") (headers : rows)
-  writeFile (outputCSV ?config) csv
-
-  -- print a nice table
-  let pads = map (maximum . map length) (transpose (headers : rowsHuman))
-      paddedHeaders = zipWith pad pads headers
-      outputRow = putStrLn . intercalate " | "
-      rowsHuman =
-        [ [ name,
-            show success,
-            show samples,
-            showDuration startup,
-            showDuration runSetup',
-            showDuration userWaits,
-            showDuration delayedWork,
-            showDuration runExperiment,
-            showMB maxResidency,
-            showMB allocations
-          ]
-          | (Bench {name, samples}, BenchRun {..}) <- results,
-            let runSetup' = if runSetup < 0.01 then 0 else runSetup
-        ]
-  outputRow paddedHeaders
-  outputRow $ (map . map) (const '-') paddedHeaders
-  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
-  where
-    cmd name dir =
-      unwords $
-        [ ghcide ?config,
-          "--lsp",
-          "--test",
-          "--cwd",
-          dir
-        ]
-          ++ case otMemoryProfiling ?config of
-            Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]
-            Nothing -> []
-          ++ [ "-RTS" ]
-          ++ ghcideOptions ?config
-          ++ concat
-            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
-            ]
-          ++ ["--verbose" | verbose ?config]
-          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
-    lspTestCaps =
-      fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
-    conf =
-      defaultConfig
-        { logStdErr = verbose ?config,
-          logMessages = verbose ?config,
-          logColor = False,
-          messageTimeout = timeoutLsp ?config
-        }
-
-data BenchRun = BenchRun
-  { startup :: !Seconds,
-    runSetup :: !Seconds,
-    runExperiment :: !Seconds,
-    userWaits :: !Seconds,
-    delayedWork :: !Seconds,
-    success :: !Bool,
-    maxResidency :: !Int,
-    allocations :: !Int
-  }
-
-badRun :: BenchRun
-badRun = BenchRun 0 0 0 0 0 False 0 0
-
-waitForProgressDone :: Session ()
-waitForProgressDone =
-      void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-
-runBench ::
-  (?config :: Config) =>
-  (Session BenchRun -> IO BenchRun) ->
-  (HasPositions => Bench) ->
-  IO BenchRun
-runBench runSess b = handleAny (\e -> print e >> return badRun)
-  $ runSess
-  $ do
-    doc <- openDoc exampleModulePath "haskell"
-
-    -- Setup the special positions used by the experiments
-    lastLine <- length . T.lines <$> documentContents doc
-    changeDoc doc [TextDocumentContentChangeEvent
-        { _range = Just (Range (Position lastLine 0) (Position lastLine 0))
-        , _rangeLength = Nothing
-        , _text = T.unlines
-               [ "_hygienic = \"hygienic\""
-               , "_identifier = _hygienic"
-               ]
-        }]
-    let
-      -- Points to a string in the target file,
-      -- convenient for hygienic edits
-      ?hygienicP = Position lastLine 15
-    let
-      -- Points to the middle of an identifier,
-      -- convenient for requesting goto-def, hover and completions
-      ?identifierP = Position (lastLine+1) 15
-
-    case b of
-     Bench{..} -> do
-      (startup, _) <- duration $ do
-        waitForProgressDone
-        -- wait again, as the progress is restarted once while loading the cradle
-        -- make an edit, to ensure this doesn't block
-        changeDoc doc [hygienicEdit]
-        waitForProgressDone
-
-      liftIO $ output $ "Running " <> name <> " benchmark"
-      (runSetup, userState) <- duration $ benchSetup doc
-      let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)
-          loop !userWaits !delayedWork n = do
-            (t, res) <- duration $ experiment userState doc
-            if not res
-              then return Nothing
-              else do
-                output (showDuration t)
-                -- Wait for the delayed actions to finish
-                waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue
-                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId
-                case resp of
-                    ResponseMessage{_result=Right Null} -> do
-                      loop (userWaits+t) (delayedWork+td) (n -1)
-                    _ ->
-                    -- Assume a ghcide build lacking the WaitForShakeQueue command
-                      loop (userWaits+t) delayedWork (n -1)
-
-      (runExperiment, result) <- duration $ loop 0 0 samples
-      let success = isJust result
-          (userWaits, delayedWork) = fromMaybe (0,0) result
-          gcStats = escapeSpaces (name <> ".benchmark-gcStats")
-
-      -- sleep to give ghcide a chance to GC
-      liftIO $ threadDelay 1100000
-
-      (maxResidency, allocations) <- liftIO $
-          ifM (doesFileExist gcStats)
-              (parseMaxResidencyAndAllocations <$> readFile gcStats)
-              (pure (0,0))
-
-      return BenchRun {..}
-
-data SetupResult = SetupResult {
-    runBenchmarks :: [Bench] -> IO (),
-    -- | Path to the setup benchmark example
-    benchDir :: FilePath,
-    cleanUp :: IO ()
-}
-
-setup :: HasConfig => IO SetupResult
-setup = do
-  alreadyExists <- doesDirectoryExist examplesPath
-  when alreadyExists $ removeDirectoryRecursive examplesPath
-  benchDir <- case example ?config of
-      UsePackage{..} -> return examplePath
-      GetPackage{..} -> do
-        let path = examplesPath </> package
-            package = exampleName <> "-" <> showVersion exampleVersion
-        case buildTool ?config of
-            Cabal -> do
-                callCommand $ "cabal get -v0 " <> package <> " -d " <> examplesPath
-                writeFile
-                    (path </> "hie.yaml")
-                    ("cradle: {cabal: {component: " <> exampleName <> "}}")
-                -- Need this in case there is a parent cabal.project somewhere
-                writeFile
-                    (path </> "cabal.project")
-                    "packages: ."
-                writeFile
-                    (path </> "cabal.project.local")
-                    ""
-            Stack -> do
-                callCommand $ "stack --silent unpack " <> package <> " --to " <> examplesPath
-                -- Generate the stack descriptor to match the one used to build ghcide
-                stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"
-                stack_yaml_lines <- lines <$> readFile stack_yaml
-                writeFile (path </> stack_yaml)
-                        (unlines $
-                        "packages: [.]" :
-                            [ l
-                            | l <- stack_yaml_lines
-                            , any (`isPrefixOf` l)
-                                ["resolver"
-                                ,"allow-newer"
-                                ,"compiler"]
-                            ]
-                        )
-
-                writeFile
-                    (path </> "hie.yaml")
-                    ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}")
-        return path
-
-  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
-
-  let cleanUp = case example ?config of
-        GetPackage{} -> removeDirectoryRecursive examplesPath
-        UsePackage{} -> return ()
-
-      runBenchmarks = runBenchmarksFun benchDir
-
-  return SetupResult{..}
-
---------------------------------------------------------------------------------------------
-
--- Parse the max residency and allocations in RTS -s output
-parseMaxResidencyAndAllocations :: String -> (Int, Int)
-parseMaxResidencyAndAllocations input =
-    (f "maximum residency", f "bytes allocated in the heap")
-  where
-    inps = reverse $ lines input
-    f label = case find (label `isInfixOf`) inps of
-        Just l -> read $ filter isDigit $ head $ words l
-        Nothing -> -1
-
-escapeSpaces :: String -> String
-escapeSpaces = map f
-  where
-    f ' ' = '_'
-    f x = x
-
-pad :: Int -> String -> String
-pad n [] = replicate n ' '
-pad 0 _ = error "pad"
-pad n (x:xx) = x : pad (n-1) xx
-
-showMB :: Int -> String
-showMB x = show (x `div` 2^(20::Int)) <> "MB"
+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}++module Experiments+( Bench(..)+, BenchRun(..)+, Config(..)+, Verbosity(..)+, CabalStack(..)+, SetupResult(..)+, Example(..)+, experiments+, configP+, defConfig+, output+, setup+, runBench+, exampleToOptions+) where+import Control.Applicative.Combinators (skipManyTill)+import Control.Exception.Safe+import Control.Monad.Extra+import Control.Monad.IO.Class+import Data.Aeson (Value(Null))+import Data.List+import Data.Maybe+import qualified Data.Text as T+import Data.Version+import Development.IDE.Plugin.Test+import Experiments.Types+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import Numeric.Natural+import Options.Applicative+import System.Directory+import System.Environment.Blank (getEnv)+import System.FilePath ((</>), (<.>))+import System.Process+import System.Time.Extra+import Text.ParserCombinators.ReadP (readP_to_S)++charEdit :: Position -> TextDocumentContentChangeEvent+charEdit p =+    TextDocumentContentChangeEvent+    { _range = Just (Range p p),+      _rangeLength = Nothing,+      _text = "a"+    }++data DocumentPositions = DocumentPositions {+    identifierP :: Maybe Position,+    stringLiteralP :: !Position,+    doc :: !TextDocumentIdentifier+}++allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool+allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs)++experiments :: [Bench]+experiments =+    [ ---------------------------------------------------------------------------------------+      bench "hover" 10 $ allWithIdentifierPos $ \DocumentPositions{..} ->+        isJust <$> getHover doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "edit" 10 $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        waitForProgressDone -- TODO check that this waits for all of them+        return True,+      ---------------------------------------------------------------------------------------+      bench "hover after edit" 10 $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          isJust <$> getHover doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "getDefinition" 10 $ allWithIdentifierPos $ \DocumentPositions{..} ->+        not . null <$> getDefinitions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "getDefinition after edit" 10 $ \docs -> do+          forM_ docs $ \DocumentPositions{..} ->+            changeDoc doc [charEdit stringLiteralP]+          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+            not . null <$> getDefinitions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "documentSymbols" 100 $ allM $ \DocumentPositions{..} -> do+        fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,+      ---------------------------------------------------------------------------------------+      bench "documentSymbols after edit" 100 $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allM docs $ \DocumentPositions{..} ->+          either (not . null) (not . null) <$> getDocumentSymbols doc,+      ---------------------------------------------------------------------------------------+      bench "completions" 10 $ \docs -> do+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          not . null <$> getCompletions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      bench "completions after edit" 10 $ \docs -> do+        forM_ docs $ \DocumentPositions{..} ->+          changeDoc doc [charEdit stringLiteralP]+        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->+          not . null <$> getCompletions doc (fromJust identifierP),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "code actions"+        10+        ( \docs -> do+            unless (any (isJust . identifierP) docs) $+                error "None of the example modules is suitable for this experiment"+            forM_ docs $ \DocumentPositions{..} ->+                forM_ identifierP $ \p -> changeDoc doc [charEdit p]+            waitForProgressDone+        )+        ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->+            forM identifierP $ \p ->+              getCodeActions doc (Range p p))+        ),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "code actions after edit"+        10+        ( \docs -> do+            unless (any (isJust . identifierP) docs) $+                error "None of the example modules is suitable for this experiment"+            forM_ docs $ \DocumentPositions{..} ->+                forM_ identifierP $ \p -> changeDoc doc [charEdit p]+        )+        ( \docs -> do+            forM_ docs $ \DocumentPositions{..} ->+              changeDoc doc [charEdit stringLiteralP]+            waitForProgressDone+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+              forM identifierP $ \p ->+                getCodeActions doc (Range p p))+        )+    ]++---------------------------------------------------------------------------------------------++examplesPath :: FilePath+examplesPath = "bench/example"++defConfig :: Config+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []++quiet, verbose :: Config -> Bool+verbose = (== All) . verbosity+quiet   = (== Quiet) . verbosity++type HasConfig = (?config :: Config)++configP :: Parser Config+configP =+  Config+    <$> (flag' All (short 'v' <> long "verbose")+         <|> flag' Quiet (short 'q' <> long "quiet")+         <|> pure Normal+        )+    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))+    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))+    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)+    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")+    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))+    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))+    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))+    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")+    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")+    <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal")+               <*> (some moduleOption <|> pure ["Distribution/Simple.hs"])+               <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0]))+         <|>+          UsePackage <$> strOption (long "example-path")+                     <*> some moduleOption+         )+  where+      moduleOption = strOption (long "example-module" <> metavar "PATH")++versionP :: ReadM Version+versionP = maybeReader $ extract . readP_to_S parseVersion+  where+      extract parses = listToMaybe [ res | (res,"") <- parses]++output :: (MonadIO m, HasConfig) => String -> m ()+output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn++---------------------------------------------------------------------------------------++type Experiment = [DocumentPositions] -> Session Bool++data Bench =+  Bench+  { name :: !String,+    enabled :: !Bool,+    samples :: !Natural,+    benchSetup :: [DocumentPositions] -> Session (),+    experiment :: Experiment+  }++select :: HasConfig => Bench -> Bool+select Bench {name, enabled} =+  enabled && (null mm || name `elem` mm)+  where+    mm = matches ?config++benchWithSetup ::+  String ->+  Natural ->+  ([DocumentPositions] -> Session ()) ->+  Experiment ->+  Bench+benchWithSetup name samples benchSetup experiment = Bench {..}+  where+    enabled = True++bench :: String -> Natural -> Experiment -> Bench+bench name defSamples =+  benchWithSetup name defSamples (const $ pure ())++runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()+runBenchmarksFun dir allBenchmarks = do+  let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }+                   | b <- allBenchmarks+                   , select b ]++  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->+      createDirectoryIfMissing True eventlogDir++  results <- forM benchmarks $ \b@Bench{name} -> do+                let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir+                (b,) <$> runBench run b++  -- output raw data as CSV+  let headers =+        [ "name"+        , "success"+        , "samples"+        , "startup"+        , "setup"+        , "userTime"+        , "delayedTime"+        , "totalTime"+        ]+      rows =+        [ [ name,+            show success,+            show samples,+            show startup,+            show runSetup',+            show userWaits,+            show delayedWork,+            show runExperiment+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+        ]+      csv = unlines $ map (intercalate ", ") (headers : rows)+  writeFile (outputCSV ?config) csv++  -- print a nice table+  let pads = map (maximum . map length) (transpose (headers : rowsHuman))+      paddedHeaders = zipWith pad pads headers+      outputRow = putStrLn . intercalate " | "+      rowsHuman =+        [ [ name,+            show success,+            show samples,+            showDuration startup,+            showDuration runSetup',+            showDuration userWaits,+            showDuration delayedWork,+            showDuration runExperiment+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+        ]+  outputRow paddedHeaders+  outputRow $ (map . map) (const '-') paddedHeaders+  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row+  where+    ghcideCmd dir =+        [ ghcide ?config,+          "--lsp",+          "--test",+          "--cwd",+          dir,+          "+RTS"+        ]+    cmd name dir =+      unwords $+            ghcideCmd dir+          ++ case otMemoryProfiling ?config of+            Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]+            Nothing -> []+          ++ [ "-RTS" ]+          ++ ghcideOptions ?config+          ++ concat+            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]+            ]+          ++ ["--verbose" | verbose ?config]+          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]+    lspTestCaps =+      fullCaps {_window = Just $ WindowClientCapabilities $ Just True}+    conf =+      defaultConfig+        { logStdErr = verbose ?config,+          logMessages = verbose ?config,+          logColor = False,+          messageTimeout = timeoutLsp ?config+        }++data BenchRun = BenchRun+  { startup :: !Seconds,+    runSetup :: !Seconds,+    runExperiment :: !Seconds,+    userWaits :: !Seconds,+    delayedWork :: !Seconds,+    success :: !Bool+  }++badRun :: BenchRun+badRun = BenchRun 0 0 0 0 0 False++waitForProgressDone :: Session ()+waitForProgressDone =+      void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)++runBench ::+  (?config :: Config) =>+  (Session BenchRun -> IO BenchRun) ->+  Bench ->+  IO BenchRun+runBench runSess b = handleAny (\e -> print e >> return badRun)+  $ runSess+  $ do+    case b of+     Bench{..} -> do+      (startup, docs) <- duration $ do+        (d, docs) <- duration $ setupDocumentContents ?config+        output $ "Setting up document contents took " <> showDuration d+        -- wait again, as the progress is restarted once while loading the cradle+        -- make an edit, to ensure this doesn't block+        let DocumentPositions{..} = head docs+        changeDoc doc [charEdit stringLiteralP]+        waitForProgressDone+        return docs++      liftIO $ output $ "Running " <> name <> " benchmark"+      (runSetup, ()) <- duration $ benchSetup docs+      let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)+          loop !userWaits !delayedWork n = do+            (t, res) <- duration $ experiment docs+            if not res+              then return Nothing+            else do+                output (showDuration t)+                -- Wait for the delayed actions to finish+                waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue+                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId+                case resp of+                    ResponseMessage{_result=Right Null} -> do+                      loop (userWaits+t) (delayedWork+td) (n -1)+                    _ ->+                    -- Assume a ghcide build lacking the WaitForShakeQueue command+                      loop (userWaits+t) delayedWork (n -1)++      (runExperiment, result) <- duration $ loop 0 0 samples+      let success = isJust result+          (userWaits, delayedWork) = fromMaybe (0,0) result++      return BenchRun {..}++data SetupResult = SetupResult {+    runBenchmarks :: [Bench] -> IO (),+    -- | Path to the setup benchmark example+    benchDir :: FilePath,+    cleanUp :: IO ()+}++callCommandLogging :: HasConfig => String -> IO ()+callCommandLogging cmd = do+    output cmd+    callCommand cmd++setup :: HasConfig => IO SetupResult+setup = do+--   when alreadyExists $ removeDirectoryRecursive examplesPath+  benchDir <- case example ?config of+      UsePackage{..} -> return examplePath+      GetPackage{..} -> do+        let path = examplesPath </> package+            package = exampleName <> "-" <> showVersion exampleVersion+        alreadySetup <- doesDirectoryExist path+        unless alreadySetup $+          case buildTool ?config of+            Cabal -> do+                let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))+                callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath+                writeFile+                    (path </> "hie.yaml")+                    ("cradle: {cabal: {component: " <> exampleName <> "}}")+                -- Need this in case there is a parent cabal.project somewhere+                writeFile+                    (path </> "cabal.project")+                    "packages: ."+                writeFile+                    (path </> "cabal.project.local")+                    ""+            Stack -> do+                let stackVerbosity = case verbosity ?config of+                        Quiet -> "--silent"+                        Normal -> ""+                        All -> "--verbose"+                callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath+                -- Generate the stack descriptor to match the one used to build ghcide+                stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"+                stack_yaml_lines <- lines <$> readFile stack_yaml+                writeFile (path </> stack_yaml)+                        (unlines $+                        "packages: [.]" :+                            [ l+                            | l <- stack_yaml_lines+                            , any (`isPrefixOf` l)+                                ["resolver"+                                ,"allow-newer"+                                ,"compiler"]+                            ]+                        )++                writeFile+                    (path </> "hie.yaml")+                    ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}")+        return path++  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True++  let cleanUp = case example ?config of+        GetPackage{} -> removeDirectoryRecursive examplesPath+        UsePackage{} -> return ()++      runBenchmarks = runBenchmarksFun benchDir++  return SetupResult{..}++setupDocumentContents :: Config -> Session [DocumentPositions]+setupDocumentContents config =+        forM (exampleModules $ example config) $ \m -> do+        doc <- openDoc m "haskell"++        -- Setup the special positions used by the experiments+        lastLine <- length . T.lines <$> documentContents doc+        changeDoc doc [TextDocumentContentChangeEvent+            { _range = Just (Range (Position lastLine 0) (Position lastLine 0))+            , _rangeLength = Nothing+            , _text = T.unlines [ "_hygienic = \"hygienic\"" ]+            }]+        let+        -- Points to a string in the target file,+        -- convenient for hygienic edits+            stringLiteralP = Position lastLine 15++        -- Find an identifier defined in another file in this project+        symbols <- getDocumentSymbols doc+        case symbols of+            Left [DocumentSymbol{_children = Just (List symbols)}] -> do+                let endOfImports = case symbols of+                        DocumentSymbol{_kind = SkModule, _name = "imports", _range } : _ ->+                            Position (succ $ _line $ _end _range) 4+                        DocumentSymbol{_range} : _ -> _start _range+                        [] -> error "Module has no symbols"+                contents <- documentContents doc++                identifierP <- searchSymbol doc contents endOfImports++                return $ DocumentPositions{..}+            other ->+                error $ "symbols: " <> show other++++--------------------------------------------------------------------------------------------++pad :: Int -> String -> String+pad n [] = replicate n ' '+pad 0 _ = error "pad"+pad n (x:xx) = x : pad (n-1) xx++-- | Search for a position where:+--     - get definition works and returns a uri other than this file+--     - get completions returns a non empty list+searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)+searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do+    -- this search is expensive, so we cache the result on disk+    let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"+    cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath+    case cachedRes of+        Left _ -> do+            result <- loop pos+            liftIO $ writeFile cachedPath $ show result+            return result+        Right res ->+            return res+  where+      loop pos+        | _line pos >= lll =+            return Nothing+        | _character pos >= lengthOfLine (_line pos) =+            loop (nextLine pos)+        | otherwise = do+                checks <- checkDefinitions pos &&^ checkCompletions pos+                if checks+                    then return $ Just pos+                    else loop (nextIdent pos)++      nextIdent p = p{_character = _character p + 2}+      nextLine p = Position (_line p + 1) 4++      lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)+      ll = T.lines fileContents+      lll = length ll++      checkDefinitions pos = do+        defs <- getDefinitions doc pos+        case defs of+            [Location uri _] -> return $ uri /= _uri+            _ -> return False+      checkCompletions pos =+        not . null <$> getCompletions doc pos
bench/lib/Experiments/Types.hs view
@@ -1,69 +1,70 @@-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Experiments.Types (module Experiments.Types ) where
-
-import Data.Aeson
-import Data.Version
-import Numeric.Natural
-import System.FilePath (isPathSeparator)
-import Development.Shake.Classes
-import GHC.Generics
-
-data CabalStack = Cabal | Stack
-  deriving (Eq, Show)
-
-data Verbosity = Quiet | Normal | All
-  deriving (Eq, Show)
-data Config = Config
-  { verbosity :: !Verbosity,
-    -- For some reason, the Shake profile files are truncated and won't load
-    shakeProfiling :: !(Maybe FilePath),
-    otMemoryProfiling :: !(Maybe FilePath),
-    outputCSV :: !FilePath,
-    buildTool :: !CabalStack,
-    ghcideOptions :: ![String],
-    matches :: ![String],
-    repetitions :: Maybe Natural,
-    ghcide :: FilePath,
-    timeoutLsp :: Int,
-    example :: Example
-  }
-  deriving (Eq, Show)
-
-data Example
-    = GetPackage {exampleName, exampleModule :: String, exampleVersion :: Version}
-    | UsePackage {examplePath :: FilePath, exampleModule :: String}
-  deriving (Eq, Generic, Show)
-  deriving anyclass (Binary, Hashable, NFData)
-
-getExampleName :: Example -> String
-getExampleName UsePackage{examplePath} = map replaceSeparator examplePath
-  where
-      replaceSeparator x
-        | isPathSeparator x = '_'
-        | otherwise = x
-getExampleName GetPackage{exampleName, exampleVersion} =
-    exampleName <> "-" <> showVersion exampleVersion
-
-instance FromJSON Example where
-    parseJSON = withObject "example" $ \x -> do
-        exampleModule <- x .: "module"
-        path <- x .:? "path"
-        case path of
-            Just examplePath -> return UsePackage{..}
-            Nothing -> do
-                exampleName <- x .: "name"
-                exampleVersion <- x .: "version"
-                return GetPackage {..}
-
-exampleToOptions :: Example -> [String]
-exampleToOptions GetPackage{..} =
-    ["--example-package-name", exampleName
-    ,"--example-package-version", showVersion exampleVersion
-    ,"--example-module", exampleModule
-    ]
-exampleToOptions UsePackage{..} =
-    ["--example-path", examplePath
-    ,"--example-module", exampleModule
-    ]
+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+module Experiments.Types (module Experiments.Types ) where++import Data.Aeson+import Data.Version+import Numeric.Natural+import System.FilePath (isPathSeparator)+import Development.Shake.Classes+import GHC.Generics++data CabalStack = Cabal | Stack+  deriving (Eq, Show)++data Verbosity = Quiet | Normal | All+  deriving (Eq, Show)+data Config = Config+  { verbosity :: !Verbosity,+    -- For some reason, the Shake profile files are truncated and won't load+    shakeProfiling :: !(Maybe FilePath),+    otMemoryProfiling :: !(Maybe FilePath),+    outputCSV :: !FilePath,+    buildTool :: !CabalStack,+    ghcideOptions :: ![String],+    matches :: ![String],+    repetitions :: Maybe Natural,+    ghcide :: FilePath,+    timeoutLsp :: Int,+    example :: Example+  }+  deriving (Eq, Show)++data Example+    = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version}+    | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]}+  deriving (Eq, Generic, Show)+  deriving anyclass (Binary, Hashable, NFData)++getExampleName :: Example -> String+getExampleName UsePackage{examplePath} = map replaceSeparator examplePath+  where+      replaceSeparator x+        | isPathSeparator x = '_'+        | otherwise = x+getExampleName GetPackage{exampleName, exampleVersion} =+    exampleName <> "-" <> showVersion exampleVersion++instance FromJSON Example where+    parseJSON = withObject "example" $ \x -> do+        exampleModules <- x .: "modules"++        path <- x .:? "path"+        case path of+            Just examplePath -> return UsePackage{..}+            Nothing -> do+                exampleName <- x .: "name"+                exampleVersion <- x .: "version"+                return GetPackage {..}++exampleToOptions :: Example -> [String]+exampleToOptions GetPackage{..} =+    ["--example-package-name", exampleName+    ,"--example-package-version", showVersion exampleVersion+    ] +++    ["--example-module=" <> m | m <- exampleModules]+exampleToOptions UsePackage{..} =+    ["--example-path", examplePath+    ] +++    ["--example-module=" <> m | m <- exampleModules]
cbits/getmodtime.c view
@@ -1,21 +1,21 @@-// Copyright (c) 2019 The DAML Authors. All rights reserved.
-// SPDX-License-Identifier: Apache-2.0
-
-#include <sys/stat.h>
-#include <time.h>
-int getmodtime(const char* pathname, time_t* sec, long* nsec) {
-    struct stat s;
-    int r = stat(pathname, &s);
-    if (r != 0) {
-        return r;
-    }
-#ifdef __APPLE__
-    *sec = s.st_mtimespec.tv_sec;
-    *nsec = s.st_mtimespec.tv_nsec;
-#else
-    *sec = s.st_mtim.tv_sec;
-    *nsec = s.st_mtim.tv_nsec;
-#endif
-    return 0;
-}
-
+// Copyright (c) 2019 The DAML Authors. All rights reserved.+// SPDX-License-Identifier: Apache-2.0++#include <sys/stat.h>+#include <time.h>+int getmodtime(const char* pathname, time_t* sec, long* nsec) {+    struct stat s;+    int r = stat(pathname, &s);+    if (r != 0) {+        return r;+    }+#ifdef __APPLE__+    *sec = s.st_mtimespec.tv_sec;+    *nsec = s.st_mtimespec.tv_nsec;+#else+    *sec = s.st_mtim.tv_sec;+    *nsec = s.st_mtim.tv_nsec;+#endif+    return 0;+}+
exe/Arguments.hs view
@@ -1,41 +1,41 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Arguments(Arguments(..), getArguments) where
-
-import Options.Applicative
-
-
-data Arguments = Arguments
-    {argLSP :: Bool
-    ,argsCwd :: Maybe FilePath
-    ,argFiles :: [FilePath]
-    ,argsVersion :: Bool
-    ,argsShakeProfiling :: Maybe FilePath
-    ,argsOTMemoryProfiling :: Bool
-    ,argsTesting :: Bool
-    ,argsDisableKick :: Bool
-    ,argsThreads :: Int
-    ,argsVerbose :: Bool
-    }
-
-getArguments :: IO Arguments
-getArguments = execParser opts
-  where
-    opts = info (arguments <**> helper)
-      ( fullDesc
-     <> progDesc "Used as a test bed to check your IDE will work"
-     <> header "ghcide - the core of a Haskell IDE")
-
-arguments :: Parser Arguments
-arguments = Arguments
-      <$> switch (long "lsp" <> help "Start talking to an LSP server")
-      <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
-      <*> many (argument str (metavar "FILES/DIRS..."))
-      <*> switch (long "version" <> help "Show ghcide and GHC versions")
-      <*> 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")
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Arguments(Arguments(..), getArguments) where++import Options.Applicative+++data Arguments = Arguments+    {argLSP :: Bool+    ,argsCwd :: Maybe FilePath+    ,argFiles :: [FilePath]+    ,argsVersion :: Bool+    ,argsShakeProfiling :: Maybe FilePath+    ,argsOTMemoryProfiling :: Bool+    ,argsTesting :: Bool+    ,argsDisableKick :: Bool+    ,argsThreads :: Int+    ,argsVerbose :: Bool+    }++getArguments :: IO Arguments+getArguments = execParser opts+  where+    opts = info (arguments <**> helper)+      ( fullDesc+     <> progDesc "Used as a test bed to check your IDE will work"+     <> header "ghcide - the core of a Haskell IDE")++arguments :: Parser Arguments+arguments = Arguments+      <$> switch (long "lsp" <> help "Start talking to an LSP server")+      <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")+      <*> many (argument str (metavar "FILES/DIRS..."))+      <*> switch (long "version" <> help "Show ghcide and GHC versions")+      <*> 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")
exe/Main.hs view
@@ -1,220 +1,220 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
-{-# LANGUAGE TemplateHaskell #-}
-
-module Main(main) where
-
-import Arguments
-import Control.Concurrent.Extra
-import Control.Monad.Extra
-import Control.Lens ( (^.) )
-import Data.Default
-import Data.List.Extra
-import Data.Maybe
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Version
-import Development.IDE.Core.Debouncer
-import Development.IDE.Core.FileStore
-import Development.IDE.Core.OfInterest
-import Development.IDE.Core.Service
-import Development.IDE.Core.Rules
-import Development.IDE.Core.Shake
-import Development.IDE.Core.RuleTypes
-import Development.IDE.LSP.Protocol
-import Development.IDE.Types.Location
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Options
-import Development.IDE.Types.Logger
-import Development.IDE.Plugin
-import Development.IDE.Plugin.Test as Test
-import Development.IDE.Session (loadSession)
-import qualified Language.Haskell.LSP.Core as LSP
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens (params, initializationOptions)
-import Development.IDE.LSP.LanguageServer
-import qualified System.Directory.Extra as IO
-import System.Environment
-import System.IO
-import System.Info
-import System.Exit
-import System.FilePath
-import System.Time.Extra
-import Paths_ghcide
-import Development.GitRev
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Aeson as J
-
-import HIE.Bios.Cradle
-import Development.IDE (action)
-import Text.Printf
-import Development.IDE.Core.Tracing
-import Development.IDE.Types.Shake (Key(Key))
-import Development.IDE.Plugin.HLS (asGhcIdePlugin)
-import Development.IDE.Plugin.HLS.GhcIde as GhcIde
-import Ide.Plugin.Config
-import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
-
-ghcideVersion :: IO String
-ghcideVersion = do
-  path <- getExecutablePath
-  let gitHashSection = case $(gitHash) of
-        x | x == "UNKNOWN" -> ""
-        x -> " (GIT hash: " <> x <> ")"
-  return $ "ghcide version: " <> showVersion version
-             <> " (GHC: " <> showVersion compilerVersion
-             <> ") (PATH: " <> path <> ")"
-             <> gitHashSection
-
-main :: IO ()
-main = do
-    -- WARNING: If you write to stdout before runLanguageServer
-    --          then the language server will not work
-    Arguments{..} <- getArguments
-
-    if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
-    else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
-
-    -- lock to avoid overlapping output on stdout
-    lock <- newLock
-    let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
-            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
-
-    whenJust argsCwd IO.setCurrentDirectory
-
-    dir <- IO.getCurrentDirectory
-
-    let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"]
-
-    pid <- T.pack . show <$> getProcessID
-    let hlsPlugin = asGhcIdePlugin hlsPlugins
-        hlsCommands = allLspCmdIds' pid hlsPlugins
-
-    let plugins = hlsPlugin
-            <> if argsTesting then Test.plugin else mempty
-        onInitialConfiguration :: InitializeRequest -> Either T.Text Config
-        onInitialConfiguration x = case x ^. params . initializationOptions of
-          Nothing -> Right def
-          Just v -> case J.fromJSON v of
-            J.Error err -> Left $ T.pack err
-            J.Success a -> Right a
-        onConfigurationChange = const $ Left "Updating Not supported"
-        options = def { LSP.executeCommandCommands = Just hlsCommands
-                      , LSP.completionTriggerCharacters = Just "."
-                      }
-
-    if argLSP then do
-        t <- offsetTime
-        hPutStrLn stderr "Starting LSP server..."
-        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do
-            t <- t
-            hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            sessionLoader <- loadSession $ fromMaybe dir rootPath
-            config <- fromMaybe def <$> getConfig
-            let options = (defaultIdeOptions sessionLoader)
-                    { optReportProgress    = clientSupportsProgress caps
-                    , optShakeProfiling    = argsShakeProfiling
-                    , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                    , optTesting           = IdeTesting argsTesting
-                    , optThreads           = argsThreads
-                    , optCheckParents      = checkParents config
-                    , optCheckProject      = checkProject config
-                    }
-                logLevel = if argsVerbose then minBound else Info
-            debouncer <- newAsyncDebouncer
-            let rules = do
-                  -- install the main and ghcide-plugin rules
-                  mainRule
-                  pluginRules plugins
-                  -- install the kick action, which triggers a typecheck on every
-                  -- Shake database restart, i.e. on every user edit.
-                  unless argsDisableKick $
-                    action kick
-            initialise caps rules
-                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs
-    else do
-        -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
-        hSetEncoding stdout utf8
-        hSetEncoding stderr utf8
-
-        putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
-        putStrLn "Report bugs at https://github.com/haskell/ghcide/issues"
-
-        putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
-        files <- expandFiles (argFiles ++ ["." | null argFiles])
-        -- LSP works with absolute file paths, so try and behave similarly
-        files <- nubOrd <$> mapM IO.canonicalizePath files
-        putStrLn $ "Found " ++ show (length files) ++ " files"
-
-        putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
-        cradles <- mapM findCradle files
-        let ucradles = nubOrd cradles
-        let n = length ucradles
-        putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
-        when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
-        putStrLn "\nStep 3/4: Initializing the IDE"
-        vfs <- makeVFSHandle
-        debouncer <- newAsyncDebouncer
-        let dummyWithProg _ _ f = f (const (pure ()))
-        sessionLoader <- loadSession dir
-        let options = (defaultIdeOptions sessionLoader)
-                    { optShakeProfiling    = argsShakeProfiling
-                    -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                    , optTesting           = IdeTesting argsTesting
-                    , optThreads           = argsThreads
-                    , optCheckParents      = NeverCheck
-                    , optCheckProject      = False
-                    }
-            logLevel = if argsVerbose then minBound else Info
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs
-
-        putStrLn "\nStep 4/4: Type checking the files"
-        setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files
-        results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)
-        _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)
-        _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)
-        let (worked, failed) = partition fst $ zip (map isJust results) files
-        when (failed /= []) $
-            putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
-
-        let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
-        putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"
-
-        when argsOTMemoryProfiling $ do
-            let valuesRef = state $ shakeExtras ide
-            values <- readVar valuesRef
-            let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)
-                consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)
-
-            printf "# Shake value store contents(%d):\n" (length values)
-            let keys = nub
-                     $ Key GhcSession : Key GhcSessionDeps
-                     : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]
-                     ++ [Key GhcSessionIO]
-            measureMemory (logger logLevel) [keys] consoleObserver valuesRef
-
-        unless (null failed) (exitWith $ ExitFailure (length failed))
-
-{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-}
-
-expandFiles :: [FilePath] -> IO [FilePath]
-expandFiles = concatMapM $ \x -> do
-    b <- IO.doesFileExist x
-    if b then return [x] else do
-        let recurse "." = True
-            recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
-            recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
-        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
-        when (null files) $
-            fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
-        return files
-
--- | Print an LSP event.
-showEvent :: Lock -> FromServerMessage -> IO ()
-showEvent _ (EventFileDiagnostics _ []) = return ()
-showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
-    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
-showEvent lock e = withLock lock $ print e
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above+{-# LANGUAGE TemplateHaskell #-}++module Main(main) where++import Arguments+import Control.Concurrent.Extra+import Control.Monad.Extra+import Control.Lens ( (^.) )+import Data.Default+import Data.List.Extra+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Version+import Development.IDE.Core.Debouncer+import Development.IDE.Core.FileStore+import Development.IDE.Core.OfInterest+import Development.IDE.Core.Service+import Development.IDE.Core.Rules+import Development.IDE.Core.Shake+import Development.IDE.Core.RuleTypes+import Development.IDE.LSP.Protocol+import Development.IDE.Types.Location+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Options+import Development.IDE.Types.Logger+import Development.IDE.Plugin+import Development.IDE.Plugin.Test as Test+import Development.IDE.Session (loadSession)+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Lens (params, initializationOptions)+import Development.IDE.LSP.LanguageServer+import qualified System.Directory.Extra as IO+import System.Environment+import System.IO+import System.Info+import System.Exit+import System.FilePath+import System.Time.Extra+import Paths_ghcide+import Development.GitRev+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Aeson as J++import HIE.Bios.Cradle+import Development.IDE (action)+import Text.Printf+import Development.IDE.Core.Tracing+import Development.IDE.Types.Shake (Key(Key))+import Development.IDE.Plugin.HLS (asGhcIdePlugin)+import Development.IDE.Plugin.HLS.GhcIde as GhcIde+import Ide.Plugin.Config+import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)++ghcideVersion :: IO String+ghcideVersion = do+  path <- getExecutablePath+  let gitHashSection = case $(gitHash) of+        x | x == "UNKNOWN" -> ""+        x -> " (GIT hash: " <> x <> ")"+  return $ "ghcide version: " <> showVersion version+             <> " (GHC: " <> showVersion compilerVersion+             <> ") (PATH: " <> path <> ")"+             <> gitHashSection++main :: IO ()+main = do+    -- WARNING: If you write to stdout before runLanguageServer+    --          then the language server will not work+    Arguments{..} <- getArguments++    if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess+    else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion++    -- lock to avoid overlapping output on stdout+    lock <- newLock+    let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $+            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg++    whenJust argsCwd IO.setCurrentDirectory++    dir <- IO.getCurrentDirectory++    let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"]++    pid <- T.pack . show <$> getProcessID+    let hlsPlugin = asGhcIdePlugin hlsPlugins+        hlsCommands = allLspCmdIds' pid hlsPlugins++    let plugins = hlsPlugin+            <> if argsTesting then Test.plugin else mempty+        onInitialConfiguration :: InitializeRequest -> Either T.Text Config+        onInitialConfiguration x = case x ^. params . initializationOptions of+          Nothing -> Right def+          Just v -> case J.fromJSON v of+            J.Error err -> Left $ T.pack err+            J.Success a -> Right a+        onConfigurationChange = const $ Left "Updating Not supported"+        options = def { LSP.executeCommandCommands = Just hlsCommands+                      , LSP.completionTriggerCharacters = Just "."+                      }++    if argLSP then do+        t <- offsetTime+        hPutStrLn stderr "Starting LSP server..."+        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"+        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do+            t <- t+            hPutStrLn stderr $ "Started LSP server in " ++ showDuration t+            sessionLoader <- loadSession $ fromMaybe dir rootPath+            config <- fromMaybe def <$> getConfig+            let options = (defaultIdeOptions sessionLoader)+                    { optReportProgress    = clientSupportsProgress caps+                    , optShakeProfiling    = argsShakeProfiling+                    , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling+                    , optTesting           = IdeTesting argsTesting+                    , optThreads           = argsThreads+                    , optCheckParents      = checkParents config+                    , optCheckProject      = checkProject config+                    }+                logLevel = if argsVerbose then minBound else Info+            debouncer <- newAsyncDebouncer+            let rules = do+                  -- install the main and ghcide-plugin rules+                  mainRule+                  pluginRules plugins+                  -- install the kick action, which triggers a typecheck on every+                  -- Shake database restart, i.e. on every user edit.+                  unless argsDisableKick $+                    action kick+            initialise caps rules+                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs+    else do+        -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error+        hSetEncoding stdout utf8+        hSetEncoding stderr utf8++        putStrLn $ "Ghcide setup tester in " ++ dir ++ "."+        putStrLn "Report bugs at https://github.com/haskell/ghcide/issues"++        putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir+        files <- expandFiles (argFiles ++ ["." | null argFiles])+        -- LSP works with absolute file paths, so try and behave similarly+        files <- nubOrd <$> mapM IO.canonicalizePath files+        putStrLn $ "Found " ++ show (length files) ++ " files"++        putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"+        cradles <- mapM findCradle files+        let ucradles = nubOrd cradles+        let n = length ucradles+        putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]+        when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"+        putStrLn "\nStep 3/4: Initializing the IDE"+        vfs <- makeVFSHandle+        debouncer <- newAsyncDebouncer+        let dummyWithProg _ _ f = f (const (pure ()))+        sessionLoader <- loadSession dir+        let options = (defaultIdeOptions sessionLoader)+                    { optShakeProfiling    = argsShakeProfiling+                    -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling+                    , optTesting           = IdeTesting argsTesting+                    , optThreads           = argsThreads+                    , optCheckParents      = NeverCheck+                    , optCheckProject      = False+                    }+            logLevel = if argsVerbose then minBound else Info+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs++        putStrLn "\nStep 4/4: Type checking the files"+        setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files+        results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)+        _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)+        _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)+        let (worked, failed) = partition fst $ zip (map isJust results) files+        when (failed /= []) $+            putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed++        let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+        putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"++        when argsOTMemoryProfiling $ do+            let valuesRef = state $ shakeExtras ide+            values <- readVar valuesRef+            let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)+                consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)++            printf "# Shake value store contents(%d):\n" (length values)+            let keys = nub+                     $ Key GhcSession : Key GhcSessionDeps+                     : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]+                     ++ [Key GhcSessionIO]+            measureMemory (logger logLevel) [keys] consoleObserver valuesRef++        unless (null failed) (exitWith $ ExitFailure (length failed))++{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-}++expandFiles :: [FilePath] -> IO [FilePath]+expandFiles = concatMapM $ \x -> do+    b <- IO.doesFileExist x+    if b then return [x] else do+        let recurse "." = True+            recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc+            recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories+        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x+        when (null files) $+            fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x+        return files++-- | Print an LSP event.+showEvent :: Lock -> FromServerMessage -> IO ()+showEvent _ (EventFileDiagnostics _ []) = return ()+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =+    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags+showEvent lock e = withLock lock $ print e
ghcide.cabal view
@@ -1,416 +1,420 @@-cabal-version:      1.20
-build-type:         Simple
-category:           Development
-name:               ghcide
-version:            0.7.0.0
-license:            Apache-2.0
-license-file:       LICENSE
-author:             Digital Asset and Ghcide contributors
-maintainer:         Ghcide contributors
-copyright:          Digital Asset and Ghcide contributors 2018-2020
-synopsis:           The core of an IDE
-description:
-    A library for building Haskell IDE's on top of the GHC API.
-homepage:           https://github.com/haskell/ghcide#readme
-bug-reports:        https://github.com/haskell/ghcide/issues
-tested-with:        GHC>=8.6.5
-extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
-                    test/data/hover/*.hs
-                    test/data/multi/cabal.project
-                    test/data/multi/hie.yaml
-                    test/data/multi/a/a.cabal
-                    test/data/multi/a/*.hs
-                    test/data/multi/b/b.cabal
-                    test/data/multi/b/*.hs
-
-source-repository head
-    type:     git
-    location: https://github.com/haskell/ghcide.git
-
-flag ghc-lib
-  description: build against ghc-lib instead of the ghc package
-  default: False
-  manual: True
-
-library
-    default-language:   Haskell2010
-    build-depends:
-        aeson,
-        array,
-        async,
-        base == 4.*,
-        binary,
-        bytestring,
-        case-insensitive,
-        containers,
-        data-default,
-        deepseq,
-        directory,
-        extra,
-        fuzzy,
-        filepath,
-        fingertree,
-        Glob,
-        haddock-library >= 1.8,
-        hashable,
-        haskell-lsp-types == 0.22.*,
-        haskell-lsp == 0.22.*,
-        hie-compat,
-        hls-plugin-api >= 0.6,
-        lens,
-        mtl,
-        network-uri,
-        parallel,
-        prettyprinter-ansi-terminal,
-        prettyprinter-ansi-terminal,
-        prettyprinter,
-        regex-tdfa >= 1.3.1.0,
-        rope-utf16-splay,
-        safe,
-        safe-exceptions,
-        shake >= 0.18.4,
-        sorted-list,
-        stm,
-        syb,
-        text,
-        time,
-        transformers,
-        unordered-containers >= 0.2.10.0,
-        utf8-string,
-        hslogger,
-        opentelemetry >=0.6.1,
-        heapsize ==0.3.*
-    if flag(ghc-lib)
-      build-depends:
-        ghc-lib >= 8.8,
-        ghc-lib-parser >= 8.8
-      cpp-options: -DGHC_LIB
-    else
-      build-depends:
-        ghc-boot-th,
-        ghc-boot,
-        ghc >= 8.6,
-        -- These dependencies are used by Development.IDE.Session and are
-        -- Haskell specific. So don't use them when building with -fghc-lib!
-        ghc-check >=0.5.0.1,
-        ghc-paths,
-        cryptohash-sha1 >=0.11.100 && <0.12,
-        hie-bios >= 0.7.1 && < 0.8.0,
-        implicit-hie-cradle >= 0.3.0.2 && < 0.4,
-        base16-bytestring >=0.1.1 && <0.2
-    if os(windows)
-      build-depends:
-        Win32
-    else
-      build-depends:
-        unix
-      c-sources:
-        cbits/getmodtime.c
-
-    default-extensions:
-        BangPatterns
-        DeriveFunctor
-        DeriveGeneric
-        FlexibleContexts
-        GeneralizedNewtypeDeriving
-        LambdaCase
-        NamedFieldPuns
-        OverloadedStrings
-        RecordWildCards
-        ScopedTypeVariables
-        StandaloneDeriving
-        TupleSections
-        TypeApplications
-        ViewPatterns
-
-    hs-source-dirs:
-        src
-    include-dirs:
-        include
-    exposed-modules:
-        Development.IDE
-        Development.IDE.Core.Debouncer
-        Development.IDE.Core.FileStore
-        Development.IDE.Core.IdeConfiguration
-        Development.IDE.Core.OfInterest
-        Development.IDE.Core.PositionMapping
-        Development.IDE.Core.Preprocessor
-        Development.IDE.Core.Rules
-        Development.IDE.Core.RuleTypes
-        Development.IDE.Core.Service
-        Development.IDE.Core.Shake
-        Development.IDE.Core.Tracing
-        Development.IDE.GHC.Compat
-        Development.IDE.GHC.Error
-        Development.IDE.GHC.Orphans
-        Development.IDE.GHC.Util
-        Development.IDE.Import.DependencyInformation
-        Development.IDE.LSP.HoverDefinition
-        Development.IDE.LSP.LanguageServer
-        Development.IDE.LSP.Outline
-        Development.IDE.LSP.Protocol
-        Development.IDE.LSP.Server
-        Development.IDE.Spans.Common
-        Development.IDE.Spans.Documentation
-        Development.IDE.Spans.AtPoint
-        Development.IDE.Spans.LocalBindings
-        Development.IDE.Types.Diagnostics
-        Development.IDE.Types.Exports
-        Development.IDE.Types.KnownTargets
-        Development.IDE.Types.Location
-        Development.IDE.Types.Logger
-        Development.IDE.Types.Options
-        Development.IDE.Types.Shake
-        Development.IDE.Plugin
-        Development.IDE.Plugin.Completions
-        Development.IDE.Plugin.CodeAction
-        Development.IDE.Plugin.HLS
-        Development.IDE.Plugin.HLS.GhcIde
-        Development.IDE.Plugin.Test
-
-    -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
-    -- the real GHC library and the types are incompatible. Furthermore, when
-    -- building with ghc-lib we need to make this Haskell agnostic, so no
-    -- hie-bios!
-    -- We also put these modules into a separate hs-source-dirs so we can avoid
-    -- compiling them at all if ghc-lib is not set
-    if !flag(ghc-lib)
-      hs-source-dirs:
-        session-loader
-      exposed-modules:
-        Development.IDE.Session
-      other-modules:
-        Development.IDE.Session.VersionCheck
-    other-modules:
-        Development.IDE.Core.Compile
-        Development.IDE.Core.FileExists
-        Development.IDE.GHC.CPP
-        Development.IDE.GHC.Warnings
-        Development.IDE.Import.FindImports
-        Development.IDE.LSP.Notifications
-        Development.IDE.Plugin.CodeAction.PositionIndexed
-        Development.IDE.Plugin.CodeAction.Rules
-        Development.IDE.Plugin.CodeAction.RuleTypes
-        Development.IDE.Plugin.Completions.Logic
-        Development.IDE.Plugin.Completions.Types
-        Development.IDE.Plugin.HLS.Formatter
-        Development.IDE.Types.Action
-    ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns
-
-executable ghcide-test-preprocessor
-    default-language: Haskell2010
-    hs-source-dirs: test/preprocessor
-    ghc-options: -Wall -Wno-name-shadowing
-    main-is: Main.hs
-    build-depends:
-        base == 4.*
-
-benchmark benchHist
-    type: exitcode-stdio-1.0
-    default-language: Haskell2010
-    ghc-options: -Wall -Wno-name-shadowing -threaded
-    main-is: Main.hs
-    hs-source-dirs: bench/hist bench/lib
-    other-modules: Experiments.Types
-    build-tool-depends:
-        ghcide:ghcide-bench
-    default-extensions:
-        BangPatterns
-        DeriveFunctor
-        DeriveGeneric
-        FlexibleContexts
-        GeneralizedNewtypeDeriving
-        LambdaCase
-        NamedFieldPuns
-        RecordWildCards
-        ScopedTypeVariables
-        StandaloneDeriving
-        TupleSections
-        TypeApplications
-        ViewPatterns
-
-    build-depends:
-        aeson,
-        base == 4.*,
-        shake-bench == 0.1.*,
-        directory,
-        filepath,
-        shake,
-        text,
-        yaml
-
-executable ghcide
-    if flag(ghc-lib)
-      buildable: False
-    default-language:   Haskell2010
-    hs-source-dirs:     exe
-    ghc-options:
-                -threaded
-                -Wall
-                -Wincomplete-uni-patterns
-                -Wno-name-shadowing
-                -- allow user RTS overrides
-                -rtsopts
-                -- disable idle GC
-                -- disable parallel GC
-                -- increase nursery size
-                "-with-rtsopts=-I0 -qg -A128M"
-    main-is: Main.hs
-    build-depends:
-        aeson,
-        base == 4.*,
-        data-default,
-        directory,
-        extra,
-        filepath,
-        gitrev,
-        hashable,
-        haskell-lsp,
-        haskell-lsp-types,
-        heapsize,
-        hie-bios,
-        hls-plugin-api,
-        ghcide,
-        lens,
-        optparse-applicative,
-        text,
-        unordered-containers
-    other-modules:
-        Arguments
-        Paths_ghcide
-
-    default-extensions:
-        BangPatterns
-        DeriveFunctor
-        DeriveGeneric
-        FlexibleContexts
-        GeneralizedNewtypeDeriving
-        LambdaCase
-        NamedFieldPuns
-        OverloadedStrings
-        RecordWildCards
-        ScopedTypeVariables
-        StandaloneDeriving
-        TupleSections
-        TypeApplications
-        ViewPatterns
-
-test-suite ghcide-tests
-    if flag(ghc-lib)
-      buildable: False
-    type: exitcode-stdio-1.0
-    default-language: Haskell2010
-    build-tool-depends:
-        ghcide:ghcide,
-        ghcide:ghcide-test-preprocessor
-    build-depends:
-        aeson,
-        base,
-        binary,
-        bytestring,
-        containers,
-        data-default,
-        directory,
-        extra,
-        filepath,
-        --------------------------------------------------------------
-        -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas
-        -- which require depending on ghc. So the tests need to depend
-        -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a
-        -- better solution can be found, but this is a quick solution
-        -- which works for now.
-        ghc,
-        --------------------------------------------------------------
-        ghcide,
-        ghc-typelits-knownnat,
-        haddock-library,
-        haskell-lsp,
-        haskell-lsp-types,
-        hls-plugin-api,
-        network-uri,
-        lens,
-        lsp-test >= 0.11.0.6 && < 0.12,
-        optparse-applicative,
-        process,
-        QuickCheck,
-        quickcheck-instances,
-        rope-utf16-splay,
-        safe,
-        safe-exceptions,
-        shake,
-        tasty,
-        tasty-expected-failure,
-        tasty-hunit,
-        tasty-quickcheck,
-        tasty-rerun,
-        text
-    if (impl(ghc >= 8.6))
-      build-depends:
-          record-dot-preprocessor,
-          record-hasfield
-    hs-source-dirs: test/cabal test/exe test/src bench/lib
-    include-dirs: include
-    ghc-options: -threaded -Wall -Wno-name-shadowing -O0
-    main-is: Main.hs
-    other-modules:
-        Development.IDE.Test
-        Development.IDE.Test.Runfiles
-        Experiments
-        Experiments.Types
-    default-extensions:
-        BangPatterns
-        DeriveFunctor
-        DeriveGeneric
-        FlexibleContexts
-        GeneralizedNewtypeDeriving
-        LambdaCase
-        NamedFieldPuns
-        OverloadedStrings
-        RecordWildCards
-        ScopedTypeVariables
-        StandaloneDeriving
-        TupleSections
-        TypeApplications
-        ViewPatterns
-
-executable ghcide-bench
-    default-language: Haskell2010
-    build-tool-depends:
-        ghcide:ghcide
-    build-depends:
-        aeson,
-        base,
-        bytestring,
-        containers,
-        directory,
-        extra,
-        filepath,
-        ghcide,
-        lsp-test >= 0.11.0.2 && < 0.12,
-        optparse-applicative,
-        process,
-        safe-exceptions,
-        shake,
-        text
-    hs-source-dirs: bench/lib bench/exe
-    include-dirs: include
-    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
-    main-is: Main.hs
-    other-modules:
-        Experiments
-        Experiments.Types
-    default-extensions:
-        BangPatterns
-        DeriveFunctor
-        DeriveGeneric
-        FlexibleContexts
-        GeneralizedNewtypeDeriving
-        LambdaCase
-        NamedFieldPuns
-        OverloadedStrings
-        RecordWildCards
-        ScopedTypeVariables
-        StandaloneDeriving
-        TupleSections
-        TypeApplications
-        ViewPatterns
+cabal-version:      1.20+build-type:         Simple+category:           Development+name:               ghcide+version:            0.7.1.0+license:            Apache-2.0+license-file:       LICENSE+author:             Digital Asset and Ghcide contributors+maintainer:         Ghcide contributors+copyright:          Digital Asset and Ghcide contributors 2018-2020+synopsis:           The core of an IDE+description:+    A library for building Haskell IDE's on top of the GHC API.+homepage:           https://github.com/haskell/ghcide#readme+bug-reports:        https://github.com/haskell/ghcide/issues+tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.1 || == 8.10.2 || == 8.10.3+extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md+                    test/data/hover/*.hs+                    test/data/multi/cabal.project+                    test/data/multi/hie.yaml+                    test/data/multi/a/a.cabal+                    test/data/multi/a/*.hs+                    test/data/multi/b/b.cabal+                    test/data/multi/b/*.hs++source-repository head+    type:     git+    location: https://github.com/haskell/ghcide.git++flag ghc-lib+  description: build against ghc-lib instead of the ghc package+  default: False+  manual: True++library+    default-language:   Haskell2010+    build-depends:+        aeson,+        array,+        async,+        base == 4.*,+        binary,+        bytestring,+        case-insensitive,+        containers,+        data-default,+        deepseq,+        directory,+        dlist,+        extra,+        fuzzy,+        filepath,+        fingertree,+        ghc-exactprint,+        Glob,+        haddock-library >= 1.8,+        hashable,+        haskell-lsp-types == 0.23.*,+        haskell-lsp == 0.23.*,+        hie-compat,+        hls-plugin-api >= 0.6,+        lens,+        mtl,+        network-uri,+        parallel,+        prettyprinter-ansi-terminal,+        prettyprinter-ansi-terminal,+        prettyprinter,+        regex-tdfa >= 1.3.1.0,+        retrie,+        rope-utf16-splay,+        safe,+        safe-exceptions,+        shake >= 0.18.4,+        sorted-list,+        stm,+        syb,+        text,+        time,+        transformers,+        unordered-containers >= 0.2.10.0,+        utf8-string,+        vector,+        hslogger,+        opentelemetry >=0.6.1,+        heapsize ==0.3.*+    if flag(ghc-lib)+      build-depends:+        ghc-lib >= 8.8,+        ghc-lib-parser >= 8.8+      cpp-options: -DGHC_LIB+    else+      build-depends:+        ghc-boot-th,+        ghc-boot,+        ghc >= 8.6,+        -- These dependencies are used by Development.IDE.Session and are+        -- Haskell specific. So don't use them when building with -fghc-lib!+        ghc-check >=0.5.0.1,+        ghc-paths,+        cryptohash-sha1 >=0.11.100 && <0.12,+        hie-bios >= 0.7.1 && < 0.8.0,+        implicit-hie-cradle >= 0.3.0.2 && < 0.4,+        base16-bytestring >=0.1.1 && <0.2+    if os(windows)+      build-depends:+        Win32+    else+      build-depends:+        unix+      c-sources:+        cbits/getmodtime.c++    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        FlexibleContexts+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++    hs-source-dirs:+        src+    include-dirs:+        include+    exposed-modules:+        Development.IDE+        Development.IDE.Core.Debouncer+        Development.IDE.Core.FileStore+        Development.IDE.Core.IdeConfiguration+        Development.IDE.Core.OfInterest+        Development.IDE.Core.PositionMapping+        Development.IDE.Core.Preprocessor+        Development.IDE.Core.Rules+        Development.IDE.Core.RuleTypes+        Development.IDE.Core.Service+        Development.IDE.Core.Shake+        Development.IDE.Core.Tracing+        Development.IDE.GHC.Compat+        Development.IDE.GHC.Error+        Development.IDE.GHC.ExactPrint+        Development.IDE.GHC.Orphans+        Development.IDE.GHC.Util+        Development.IDE.Import.DependencyInformation+        Development.IDE.LSP.HoverDefinition+        Development.IDE.LSP.LanguageServer+        Development.IDE.LSP.Outline+        Development.IDE.LSP.Protocol+        Development.IDE.LSP.Server+        Development.IDE.Spans.Common+        Development.IDE.Spans.Documentation+        Development.IDE.Spans.AtPoint+        Development.IDE.Spans.LocalBindings+        Development.IDE.Types.Diagnostics+        Development.IDE.Types.Exports+        Development.IDE.Types.KnownTargets+        Development.IDE.Types.Location+        Development.IDE.Types.Logger+        Development.IDE.Types.Options+        Development.IDE.Types.Shake+        Development.IDE.Plugin+        Development.IDE.Plugin.Completions+        Development.IDE.Plugin.CodeAction+        Development.IDE.Plugin.HLS+        Development.IDE.Plugin.HLS.GhcIde+        Development.IDE.Plugin.Test++    -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses+    -- the real GHC library and the types are incompatible. Furthermore, when+    -- building with ghc-lib we need to make this Haskell agnostic, so no+    -- hie-bios!+    -- We also put these modules into a separate hs-source-dirs so we can avoid+    -- compiling them at all if ghc-lib is not set+    if !flag(ghc-lib)+      hs-source-dirs:+        session-loader+      exposed-modules:+        Development.IDE.Session+      other-modules:+        Development.IDE.Session.VersionCheck+    other-modules:+        Development.IDE.Core.Compile+        Development.IDE.Core.FileExists+        Development.IDE.GHC.CPP+        Development.IDE.GHC.Warnings+        Development.IDE.Import.FindImports+        Development.IDE.LSP.Notifications+        Development.IDE.Plugin.CodeAction.PositionIndexed+        Development.IDE.Plugin.CodeAction.Rules+        Development.IDE.Plugin.CodeAction.RuleTypes+        Development.IDE.Plugin.Completions.Logic+        Development.IDE.Plugin.Completions.Types+        Development.IDE.Plugin.HLS.Formatter+        Development.IDE.Types.Action+    ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns++executable ghcide-test-preprocessor+    default-language: Haskell2010+    hs-source-dirs: test/preprocessor+    ghc-options: -Wall -Wno-name-shadowing+    main-is: Main.hs+    build-depends:+        base == 4.*++benchmark benchHist+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    ghc-options: -Wall -Wno-name-shadowing -threaded+    main-is: Main.hs+    hs-source-dirs: bench/hist bench/lib+    other-modules: Experiments.Types+    build-tool-depends:+        ghcide:ghcide-bench+    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        FlexibleContexts+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++    build-depends:+        aeson,+        base == 4.*,+        shake-bench == 0.1.*,+        directory,+        filepath,+        shake,+        text,+        yaml++executable ghcide+    if flag(ghc-lib)+      buildable: False+    default-language:   Haskell2010+    hs-source-dirs:     exe+    ghc-options:+                -threaded+                -Wall+                -Wincomplete-uni-patterns+                -Wno-name-shadowing+                -- allow user RTS overrides+                -rtsopts+                -- disable idle GC+                -- increase nursery size+                "-with-rtsopts=-I0 -A128M"+    main-is: Main.hs+    build-depends:+        aeson,+        base == 4.*,+        data-default,+        directory,+        extra,+        filepath,+        gitrev,+        hashable,+        haskell-lsp,+        haskell-lsp-types,+        heapsize,+        hie-bios,+        hls-plugin-api,+        ghcide,+        lens,+        optparse-applicative,+        text,+        unordered-containers+    other-modules:+        Arguments+        Paths_ghcide++    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        FlexibleContexts+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++test-suite ghcide-tests+    if flag(ghc-lib)+      buildable: False+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    build-tool-depends:+        ghcide:ghcide,+        ghcide:ghcide-test-preprocessor+    build-depends:+        aeson,+        base,+        binary,+        bytestring,+        containers,+        data-default,+        directory,+        extra,+        filepath,+        --------------------------------------------------------------+        -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas+        -- which require depending on ghc. So the tests need to depend+        -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a+        -- better solution can be found, but this is a quick solution+        -- which works for now.+        ghc,+        --------------------------------------------------------------+        ghcide,+        ghc-typelits-knownnat,+        haddock-library,+        haskell-lsp,+        haskell-lsp-types,+        hls-plugin-api,+        network-uri,+        lens,+        lsp-test >= 0.11.0.6 && < 0.12,+        optparse-applicative,+        process,+        QuickCheck,+        quickcheck-instances,+        rope-utf16-splay,+        safe,+        safe-exceptions,+        shake,+        tasty,+        tasty-expected-failure,+        tasty-hunit,+        tasty-quickcheck,+        tasty-rerun,+        text+    if (impl(ghc >= 8.6))+      build-depends:+          record-dot-preprocessor,+          record-hasfield+    hs-source-dirs: test/cabal test/exe test/src bench/lib+    include-dirs: include+    ghc-options: -threaded -Wall -Wno-name-shadowing -O0+    main-is: Main.hs+    other-modules:+        Development.IDE.Test+        Development.IDE.Test.Runfiles+        Experiments+        Experiments.Types+    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        FlexibleContexts+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++executable ghcide-bench+    default-language: Haskell2010+    build-tool-depends:+        ghcide:ghcide+    build-depends:+        aeson,+        base,+        bytestring,+        containers,+        directory,+        extra,+        filepath,+        ghcide,+        lsp-test >= 0.11.0.2 && < 0.12,+        optparse-applicative,+        process,+        safe-exceptions,+        shake,+        text+    hs-source-dirs: bench/lib bench/exe+    include-dirs: include+    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts+    main-is: Main.hs+    other-modules:+        Experiments+        Experiments.Types+    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        FlexibleContexts+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns
include/ghc-api-version.h view
@@ -1,12 +1,12 @@-#ifndef GHC_API_VERSION_H
-#define GHC_API_VERSION_H
-
-#ifdef GHC_LIB
-#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)
-#define GHC_API_VERSION VERSION_ghc_lib
-#else
-#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
-#define GHC_API_VERSION VERSION_ghc
-#endif
-
-#endif
+#ifndef GHC_API_VERSION_H+#define GHC_API_VERSION_H++#ifdef GHC_LIB+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)+#define GHC_API_VERSION VERSION_ghc_lib+#else+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)+#define GHC_API_VERSION VERSION_ghc+#endif++#endif
session-loader/Development/IDE/Session.hs view
@@ -1,778 +1,778 @@-{-# LANGUAGE TypeFamilies #-}
-
-{-|
-The logic for setting up a ghcide session by tapping into hie-bios.
--}
-module Development.IDE.Session
-  (SessionLoadingOptions(..)
-  ,defaultLoadingOptions
-  ,loadSession
-  ,loadSessionWithOptions
-  ) where
-
--- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
--- the real GHC library and the types are incompatible. Furthermore, when
--- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!
-
-import Control.Concurrent.Async
-import Control.Concurrent.Extra
-import Control.Exception.Safe
-import Control.Monad
-import Control.Monad.Extra
-import Control.Monad.IO.Class
-import qualified Crypto.Hash.SHA1 as H
-import qualified Data.ByteString.Char8 as B
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as T
-import Data.Aeson
-import Data.Bifunctor
-import qualified Data.ByteString.Base16 as B16
-import Data.Either.Extra
-import Data.Function
-import Data.Hashable
-import Data.List
-import Data.IORef
-import Data.Maybe
-import Data.Time.Clock
-import Data.Version
-import Development.IDE.Core.Shake
-import Development.IDE.Core.RuleTypes
-import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)
-import qualified Development.IDE.GHC.Compat as GHC
-import Development.IDE.GHC.Util
-import Development.IDE.Session.VersionCheck
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Exports
-import Development.IDE.Types.Location
-import Development.IDE.Types.Logger
-import Development.IDE.Types.Options
-import Development.Shake (Action)
-import GHC.Check
-import qualified HIE.Bios as HieBios
-import HIE.Bios.Environment hiding (getCacheDir)
-import HIE.Bios.Types
-import Hie.Implicit.Cradle (loadImplicitHieCradle)
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import System.Directory
-import qualified System.Directory.Extra as IO
-import System.FilePath
-import System.Info
-import System.IO
-
-import GHCi
-import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC)
-import Linker
-import Module
-import NameCache
-import Packages
-import Control.Exception (evaluate)
-import Data.Void
-
-
-data CacheDirs = CacheDirs
-  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
-
-data SessionLoadingOptions = SessionLoadingOptions
-  { findCradle :: FilePath -> IO (Maybe FilePath)
-  , loadCradle :: FilePath -> IO (HieBios.Cradle Void)
-  -- | Given the project name and a set of command line flags,
-  --   return the path for storing generated GHC artifacts,
-  --   or 'Nothing' to respect the cradle setting
-  , getCacheDirs :: String -> [String] -> IO CacheDirs
-  }
-
-defaultLoadingOptions :: SessionLoadingOptions
-defaultLoadingOptions = SessionLoadingOptions
-    {findCradle = HieBios.findCradle
-    ,loadCradle = HieBios.loadCradle
-    ,getCacheDirs = getCacheDirsDefault
-    }
-
--- | Given a root directory, return a Shake 'Action' which setups an
--- 'IdeGhcSession' given a file.
--- Some of the many things this does:
---
--- * Find the cradle for the file
--- * Get the session options,
--- * Get the GHC lib directory
--- * Make sure the GHC compiletime and runtime versions match
--- * Restart the Shake session
---
--- This is the key function which implements multi-component support. All
--- components mapping to the same hie.yaml file are mapped to the same
--- HscEnv which is updated as new components are discovered.
-loadSession :: FilePath -> IO (Action IdeGhcSession)
-loadSession = loadSessionWithOptions defaultLoadingOptions
-
-loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
-loadSessionWithOptions SessionLoadingOptions{..} dir = do
-  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
-  hscEnvs <- newVar Map.empty :: IO (Var HieMap)
-  -- Mapping from a Filepath to HscEnv
-  fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
-  -- Version of the mappings above
-  version <- newVar 0
-  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
-  let invalidateShakeCache = do
-        modifyVar_ version (return . succ)
-  -- This caches the mapping from Mod.hs -> hie.yaml
-  cradleLoc <- liftIO $ memoIO $ \v -> do
-      res <- findCradle v
-      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
-      -- try and normalise that
-      -- e.g. see https://github.com/haskell/ghcide/issues/126
-      res' <- traverse makeAbsolute res
-      return $ normalise <$> res'
-
-  dummyAs <- async $ return (error "Uninitialised")
-  runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
-
-  return $ do
-    extras@ShakeExtras{logger, eventer, restartShakeSession,
-                       withIndefiniteProgress, ideNc, knownTargetsVar
-                      } <- getShakeExtras
-
-    IdeOptions{ optTesting = IdeTesting optTesting
-              , optCheckProject = checkProject
-              , optCustomDynFlags
-              , optExtensions
-              } <- getIdeOptions
-
-        -- populate the knownTargetsVar with all the
-        -- files in the project so that `knownFiles` can learn about them and
-        -- we can generate a complete module graph
-    let extendKnownTargets newTargets = do
-          knownTargets <- forM newTargets $ \TargetDetails{..} ->
-            case targetTarget of
-              TargetFile f -> pure (targetTarget, [f])
-              TargetModule _ -> do
-                found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
-                return (targetTarget, found)
-          modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do
-            let known' = HM.unionWith (<>) known $ HM.fromList knownTargets
-            when (known /= known') $
-                logDebug logger $ "Known files updated: " <>
-                    T.pack(show $ (HM.map . map) fromNormalizedFilePath known')
-            evaluate known'
-
-    -- Create a new HscEnv from a hieYaml root and a set of options
-    -- If the hieYaml file already has an HscEnv, the new component is
-    -- combined with the components in the old HscEnv into a new HscEnv
-    -- which contains the union.
-    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-                     -> IO (HscEnv, ComponentInfo, [ComponentInfo])
-        packageSetup (hieYaml, cfp, opts, libDir) = do
-          -- Parse DynFlags for the newly discovered component
-          hscEnv <- emptyHscEnv ideNc libDir
-          (df, targets) <- evalGhcEnv hscEnv $
-              first optCustomDynFlags <$> 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
-          -- or making a new one. The lookup returns the HscEnv and a list of
-          -- information about other components loaded into the HscEnv
-          -- (unitId, DynFlag, Targets)
-          modifyVar hscEnvs $ \m -> do
-              -- Just deps if there's already an HscEnv
-              -- Nothing is it's the first time we are making an HscEnv
-              let oldDeps = Map.lookup hieYaml m
-              let -- Add the raw information about this component to the list
-                  -- We will modify the unitId and DynFlags used for
-                  -- compilation but these are the true source of
-                  -- information.
-                  new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info
-                                : maybe [] snd oldDeps
-                  -- Get all the unit-ids for things in this component
-                  inplace = map rawComponentUnitId new_deps
-
-              new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
-                  -- Remove all inplace dependencies from package flags for
-                  -- components in this HscEnv
-                  let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
-                  let prefix = show rawComponentUnitId
-                  -- See Note [Avoiding bad interface files]
-                  let hscComponents = sort $ map show uids
-                      cacheDirOpts = hscComponents ++ componentOptions opts
-                  cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts
-                  processed_df <- setCacheDirs logger cacheDirs df2
-                  -- The final component information, mostly the same but the DynFlags don't
-                  -- contain any packages which are also loaded
-                  -- into the same component.
-                  pure $ ComponentInfo rawComponentUnitId
-                                       processed_df
-                                       uids
-                                       rawComponentTargets
-                                       rawComponentFP
-                                       rawComponentCOptions
-                                       rawComponentDependencyInfo
-              -- Make a new HscEnv, we have to recompile everything from
-              -- scratch again (for now)
-              -- It's important to keep the same NameCache though for reasons
-              -- that I do not fully understand
-              logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
-              hscEnv <- emptyHscEnv ideNc libDir
-              newHscEnv <-
-                -- Add the options for the current component to the HscEnv
-                evalGhcEnv hscEnv $ do
-                  _ <- setSessionDynFlags df
-                  getSession
-
-              -- Modify the map so the hieYaml now maps to the newly created
-              -- HscEnv
-              -- Returns
-              -- . the new HscEnv so it can be used to modify the
-              --   FilePath -> HscEnv map (fileToFlags)
-              -- . The information for the new component which caused this cache miss
-              -- . The modified information (without -inplace flags) for
-              --   existing packages
-              pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
-
-
-    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
-                -> IO (IdeResult HscEnvEq,[FilePath])
-        session args@(hieYaml, _cfp, _opts, _libDir) = do
-          (hscEnv, new, old_deps) <- packageSetup args
-
-          -- Whenever we spin up a session on Linux, dynamically load libm.so.6
-          -- in. We need this in case the binary is statically linked, in which
-          -- case the interactive session will fail when trying to load
-          -- ghc-prim, which happens whenever Template Haskell is being
-          -- evaluated or haskell-language-server's eval plugin tries to run
-          -- some code. If the binary is dynamically linked, then this will have
-          -- no effect.
-          -- See https://github.com/haskell/haskell-language-server/issues/221
-          when (os == "linux") $ do
-            initObjLinker hscEnv
-            res <- loadDLL hscEnv "libm.so.6"
-            case res of
-              Nothing -> pure ()
-              Just err -> hPutStrLn stderr $
-                "Error dynamically loading libm.so.6:\n" <> err
-
-          -- Make a map from unit-id to DynFlags, this is used when trying to
-          -- resolve imports. (especially PackageImports)
-          let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
-
-          -- For each component, now make a new HscEnvEq which contains the
-          -- HscEnv for the hie.yaml file but the DynFlags for that component
-
-          -- New HscEnv for the component in question, returns the new HscEnvEq and
-          -- a mapping from FilePath to the newly created HscEnvEq.
-          let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids
-          (cs, res) <- new_cache new
-          -- Modified cache targets for everything else in the hie.yaml file
-          -- which now uses the same EPS and so on
-          cached_targets <- concatMapM (fmap fst . new_cache) old_deps
-
-          let all_targets = cs ++ cached_targets
-
-          modifyVar_ fileToFlags $ \var -> do
-              pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var
-
-          extendKnownTargets all_targets
-
-          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
-          invalidateShakeCache
-          restartShakeSession []
-
-          -- Typecheck all files in the project on startup
-          unless (null cs || not checkProject) $ do
-                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)
-                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-                    mmt <- uses GetModificationTime cfps'
-                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
-                    modIfaces <- uses GetModIface cs_exist
-                    -- update exports map
-                    extras <- getShakeExtras
-                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
-                    liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)
-
-          return (second Map.keys res)
-
-    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-        consultCradle hieYaml cfp = do
-           lfp <- flip makeRelative cfp <$> getCurrentDirectory
-           logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)
-
-           when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp
-
-           cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
-
-           when optTesting $ eventer $ notifyCradleLoaded lfp
-
-           -- Display a user friendly progress message here: They probably don't know what a cradle is
-           let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
-                         <> " (for " <> T.pack lfp <> ")"
-           eopts <- withIndefiniteProgress progMsg NotCancellable $
-             cradleToOptsAndLibDir cradle cfp
-
-           logDebug logger $ T.pack ("Session loading result: " <> show eopts)
-           case eopts of
-             -- The cradle gave us some options so get to work turning them
-             -- into and HscEnv.
-             Right (opts, libDir) -> do
-               installationCheck <- ghcVersionChecker libDir
-               case installationCheck of
-                 InstallationNotFound{..} ->
-                     error $ "GHC installation not found in libdir: " <> libdir
-                 InstallationMismatch{..} ->
-                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
-                 InstallationChecked _compileTime _ghcLibCheck ->
-                   session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
-             -- Failure case, either a cradle error or the none cradle
-             Left err -> do
-               dep_info <- getDependencyInfo (maybeToList hieYaml)
-               let ncfp = toNormalizedFilePath' cfp
-               let res = (map (renderCradleError ncfp) err, Nothing)
-               modifyVar_ fileToFlags $ \var -> do
-                 pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
-               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
-
-    -- This caches the mapping from hie.yaml + Mod.hs -> [String]
-    -- Returns the Ghc session and the cradle dependencies
-    let sessionOpts :: (Maybe FilePath, FilePath)
-                    -> IO (IdeResult HscEnvEq, [FilePath])
-        sessionOpts (hieYaml, file) = do
-          v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
-          cfp <- canonicalizePath file
-          case HM.lookup (toNormalizedFilePath' cfp) v of
-            Just (opts, old_di) -> do
-              deps_ok <- checkDependencyInfo old_di
-              if not deps_ok
-                then do
-                  -- If the dependencies are out of date then clear both caches and start
-                  -- again.
-                  modifyVar_ fileToFlags (const (return Map.empty))
-                  -- Keep the same name cache
-                  modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
-                  consultCradle hieYaml cfp
-                else return (opts, Map.keys old_di)
-            Nothing -> consultCradle hieYaml cfp
-
-    -- The main function which gets options for a file. We only want one of these running
-    -- at a time. Therefore the IORef contains the currently running cradle, if we try
-    -- to get some more options then we wait for the currently running action to finish
-    -- before attempting to do so.
-    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-        getOptions file = do
-            hieYaml <- cradleLoc file
-            sessionOpts (hieYaml, file) `catch` \e ->
-                return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
-
-    returnWithVersion $ \file -> do
-      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
-        -- If the cradle is not finished, then wait for it to finish.
-        void $ wait as
-        as <- async $ getOptions file
-        return (as, wait as)
-      pure opts
-
--- | Run the specific cradle on a specific FilePath via hie-bios.
--- This then builds dependencies or whatever based on the cradle, gets the
--- GHC options/dynflags needed for the session and the GHC library directory
-
-cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
-                      -> IO (Either [CradleError] (ComponentOptions, FilePath))
-cradleToOptsAndLibDir cradle file = do
-    -- Start off by getting the session options
-    let showLine s = hPutStrLn stderr ("> " ++ s)
-    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
-    cradleRes <- runCradle (cradleOptsProg cradle) showLine file
-    case cradleRes of
-        CradleSuccess r -> do
-            -- Now get the GHC lib dir
-            libDirRes <- getRuntimeGhcLibDir cradle
-            case libDirRes of
-                -- This is the successful path
-                CradleSuccess libDir -> pure (Right (r, libDir))
-                CradleFail err -> return (Left [err])
-                -- For the None cradle perhaps we still want to report an Info
-                -- message about the fact that the file is being ignored.
-                CradleNone -> return (Left [])
-
-        CradleFail err -> return (Left [err])
-        -- Same here
-        CradleNone -> return (Left [])
-
-emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
-emptyHscEnv nc libDir = do
-    env <- runGhc (Just libDir) getSession
-    initDynLinker env
-    pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }
-
-data TargetDetails = TargetDetails
-  {
-      targetTarget :: !Target,
-      targetEnv :: !(IdeResult HscEnvEq),
-      targetDepends :: !DependencyInfo,
-      targetLocations :: ![NormalizedFilePath]
-  }
-
-fromTargetId :: [FilePath]          -- ^ import paths
-             -> [String]            -- ^ extensions to consider
-             -> TargetId
-             -> IdeResult HscEnvEq
-             -> DependencyInfo
-             -> IO [TargetDetails]
--- For a target module we consider all the import paths
-fromTargetId is exts (GHC.TargetModule mod) env dep = do
-    let fps = [i </> moduleNameSlashes mod -<.> ext <> boot
-              | ext <- exts
-              , i <- is
-              , boot <- ["", "-boot"]
-              ]
-    locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
-    return [TargetDetails (TargetModule mod) env dep locs]
--- For a 'TargetFile' we consider all the possible module names
-fromTargetId _ _ (GHC.TargetFile f _) env deps = do
-    nf <- toNormalizedFilePath' <$> canonicalizePath f
-    return [TargetDetails (TargetFile nf) env deps [nf]]
-
-toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
-toFlagsMap TargetDetails{..} =
-    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]
-
-
-setNameCache :: IORef NameCache -> HscEnv -> HscEnv
-setNameCache nc hsc = hsc { hsc_NC = nc }
-
--- | Create a mapping from FilePaths to HscEnvEqs
-newComponentCache
-         :: Logger
-         -> [String]       -- File extensions to consider
-         -> Maybe FilePath -- Path to cradle
-         -> NormalizedFilePath -- Path to file that caused the creation of this component
-         -> HscEnv
-         -> [(InstalledUnitId, DynFlags)]
-         -> ComponentInfo
-         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))
-newComponentCache logger exts cradlePath cfp hsc_env uids ci = do
-    let df = componentDynFlags ci
-    let hscEnv' = hsc_env { hsc_dflags = df
-                          , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
-
-    let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
-    henv <- newFunc hscEnv' uids
-    let targetEnv = ([], Just henv)
-        targetDepends = componentDependencyInfo ci
-        res = (targetEnv, targetDepends)
-    logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))
-
-    let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
-    ctargets <- concatMapM mk (componentTargets ci)
-
-    -- A special target for the file which caused this wonderful
-    -- component to be created. In case the cradle doesn't list all the targets for
-    -- the component, in which case things will be horribly broken anyway.
-    -- Otherwise, we will immediately attempt to reload this module which
-    -- causes an infinite loop and high CPU usage.
-    let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci]
-    return (special_target:ctargets, res)
-
-{- Note [Avoiding bad interface files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Originally, we set the cache directory for the various components once
-on the first occurrence of the component.
-This works fine if these components have no references to each other,
-but you have components that depend on each other, the interface files are
-updated for each component.
-After restarting the session and only opening the component that depended
-on the other, suddenly the interface files of this component are stale.
-However, from the point of view of `ghcide`, they do not look stale,
-thus, not regenerated and the IDE shows weird errors such as:
-```
-typecheckIface
-Declaration for Rep_ClientRunFlags
-Axiom branches Rep_ClientRunFlags:
-  Failed to load interface for ‘Distribution.Simple.Flag’
-  Use -v to see a list of the files searched for.
-```
-and
-```
-expectJust checkFamInstConsistency
-CallStack (from HasCallStack):
-  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes
-  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
-```
-
-To mitigate this, we set the cache directory for each component dependent
-on the components of the current `HscEnv`, additionally to the component options
-of the respective components.
-Assume two components, c1, c2, where c2 depends on c1, and the options of the
-respective components are co1, co2.
-If we want to load component c2, followed by c1, we set the cache directory for
-each component in this way:
-
-  * Load component c2
-    * (Cache Directory State)
-        - name of c2 + co2
-  * Load component c1
-    * (Cache Directory State)
-        - name of c2 + name of c1 + co2
-        - name of c2 + name of c1 + co1
-
-Overall, we created three cache directories. If we opened c1 first, then we
-create a fourth cache directory.
-This makes sure that interface files are always correctly updated.
-
-Since this causes a lot of recompilation, we only update the cache-directory,
-if the dependencies of a component have really changed.
-E.g. when you load two executables, they can not depend on each other. They
-should be filtered out, such that we dont have to re-compile everything.
--}
-
--- | Set the cache-directory based on the ComponentOptions and a list of
--- internal packages.
--- For the exact reason, see Note [Avoiding bad interface files].
-setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags
-setCacheDirs logger CacheDirs{..} dflags = do
-    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir
-    pure $ dflags
-          & maybe id setHiDir hiCacheDir
-          & maybe id setHieDir hieCacheDir
-          & maybe id setODir oCacheDir
-
-
-renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
-renderCradleError nfp (CradleError _ _ec t) =
-  ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t))
-
--- See Note [Multi Cradle Dependency Info]
-type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
-type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])
-type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
-
--- This is pristine information about a component
-data RawComponentInfo = RawComponentInfo
-  { rawComponentUnitId :: InstalledUnitId
-  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.
-  -- We do not want to use them unprocessed.
-  , rawComponentDynFlags :: DynFlags
-  -- | All targets of this components.
-  , rawComponentTargets :: [GHC.Target]
-  -- | Filepath which caused the creation of this component
-  , rawComponentFP :: NormalizedFilePath
-  -- | Component Options used to load the component.
-  , rawComponentCOptions :: ComponentOptions
-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
-  -- to last modification time. See Note [Multi Cradle Dependency Info].
-  , rawComponentDependencyInfo :: DependencyInfo
-  }
-
--- This is processed information about the component, in particular the dynflags will be modified.
-data ComponentInfo = ComponentInfo
-  { componentUnitId :: InstalledUnitId
-  -- | Processed DynFlags. Does not contain inplace packages such as local
-  -- libraries. Can be used to actually load this Component.
-  , componentDynFlags :: DynFlags
-  -- | Internal units, such as local libraries, that this component
-  -- is loaded with. These have been extracted from the original
-  -- ComponentOptions.
-  , _componentInternalUnits :: [InstalledUnitId]
-  -- | All targets of this components.
-  , componentTargets :: [GHC.Target]
-  -- | Filepath which caused the creation of this component
-  , componentFP :: NormalizedFilePath
-  -- | Component Options used to load the component.
-  , _componentCOptions :: ComponentOptions
-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
-  -- to last modification time. See Note [Multi Cradle Dependency Info]
-  , componentDependencyInfo :: DependencyInfo
-  }
-
--- | Check if any dependency has been modified lately.
-checkDependencyInfo :: DependencyInfo -> IO Bool
-checkDependencyInfo old_di = do
-  di <- getDependencyInfo (Map.keys old_di)
-  return (di == old_di)
-
--- Note [Multi Cradle Dependency Info]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Why do we implement our own file modification tracking here?
--- The primary reason is that the custom caching logic is quite complicated and going into shake
--- adds even more complexity and more indirection. I did try for about 5 hours to work out how to
--- use shake rules rather than IO but eventually gave up.
-
--- | Computes a mapping from a filepath to its latest modification date.
--- See Note [Multi Cradle Dependency Info] why we do this ourselves instead
--- of letting shake take care of it.
-getDependencyInfo :: [FilePath] -> IO DependencyInfo
-getDependencyInfo fs = Map.fromList <$> mapM do_one fs
-
-  where
-    tryIO :: IO a -> IO (Either IOException a)
-    tryIO = try
-
-    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
-    do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)
-
--- | This function removes all the -package flags which refer to packages we
--- are going to deal with ourselves. For example, if a executable depends
--- on a library component, then this function will remove the library flag
--- from the package flags for the executable
---
--- There are several places in GHC (for example the call to hptInstances in
--- tcRnImports) which assume that all modules in the HPT have the same unit
--- ID. Therefore we create a fake one and give them all the same unit id.
-removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
-removeInplacePackages us df = (df { packageFlags = ps
-                                  , thisInstalledUnitId = fake_uid }, uids)
-  where
-    (uids, ps) = partitionEithers (map go (packageFlags df))
-    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
-    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
-                                                  then Left (toInstalledUnitId u)
-                                                  else Right p
-    go p = Right p
-
--- | Memoize an IO function, with the characteristics:
---
---   * If multiple people ask for a result simultaneously, make sure you only compute it once.
---
---   * If there are exceptions, repeatedly reraise them.
---
---   * If the caller is aborted (async exception) finish computing it anyway.
-memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)
-memoIO op = do
-    ref <- newVar Map.empty
-    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->
-        case Map.lookup k mp of
-            Nothing -> do
-                res <- onceFork $ op k
-                return (Map.insert k res mp, res)
-            Just res -> return (mp, res)
-
--- | Throws if package flags are unsatisfiable
-setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target])
-setOptions (ComponentOptions theOpts compRoot _) dflags = do
-    (dflags', targets') <- addCmdOpts theOpts dflags
-    let targets = makeTargetsAbsolute compRoot targets'
-    let dflags'' =
-          disableWarningsAsErrors $
-          -- disabled, generated directly by ghcide instead
-          flip gopt_unset Opt_WriteInterface $
-          -- disabled, generated directly by ghcide instead
-          -- also, it can confuse the interface stale check
-          dontWriteHieFiles $
-          setIgnoreInterfacePragmas $
-          setLinkerOptions $
-          disableOptimisation $
-          setUpTypedHoles $
-          makeDynFlagsAbsolute compRoot dflags'
-    -- initPackages parses the -package flags and
-    -- sets up the visibility for each component.
-    -- Throws if a -package flag cannot be satisfied.
-    (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''
-    return (final_df, targets)
-
-
--- we don't want to generate object code so we compile to bytecode
--- (HscInterpreted) which implies LinkInMemory
--- HscInterpreted
-setLinkerOptions :: DynFlags -> DynFlags
-setLinkerOptions df = df {
-    ghcLink   = LinkInMemory
-  , hscTarget = HscNothing
-  , ghcMode = CompManager
-  }
-
-setIgnoreInterfacePragmas :: DynFlags -> DynFlags
-setIgnoreInterfacePragmas df =
-    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
-
-disableOptimisation :: DynFlags -> DynFlags
-disableOptimisation df = updOptLevel 0 df
-
-setHiDir :: FilePath -> DynFlags -> DynFlags
-setHiDir f d =
-    -- override user settings to avoid conflicts leading to recompilation
-    d { hiDir      = Just f}
-
-setODir :: FilePath -> DynFlags -> DynFlags
-setODir f d =
-    -- override user settings to avoid conflicts leading to recompilation
-    d { objectDir = Just f}
-
-getCacheDirsDefault :: String -> [String] -> IO CacheDirs
-getCacheDirsDefault prefix opts = do
-    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
-    return $ CacheDirs dir dir dir
-    where
-        -- Create a unique folder per set of different GHC options, assuming that each different set of
-        -- GHC options will create incompatible interface files.
-        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)
-
--- | Sub directory for the cache path
-cacheDir :: String
-cacheDir = "ghcide"
-
-notifyUserImplicitCradle:: FilePath -> FromServerMessage
-notifyUserImplicitCradle fp =
-    NotShowMessage $
-    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $
-      "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
-      <> T.pack fp <>
-      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\
-      \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
-
-notifyCradleLoaded :: FilePath -> FromServerMessage
-notifyCradleLoaded fp =
-    NotCustomServer $
-    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $
-    toJSON fp
-
-cradleLoadedMethod :: T.Text
-cradleLoadedMethod = "ghcide/cradle/loaded"
-
-----------------------------------------------------------------------------------------------------
-
-data PackageSetupException
-    = PackageSetupException
-        { message     :: !String
-        }
-    | GhcVersionMismatch
-        { compileTime :: !Version
-        , runTime     :: !Version
-        }
-    | PackageCheckFailed !NotCompatibleReason
-    deriving (Eq, Show, Typeable)
-
-instance Exception PackageSetupException
-
--- | Wrap any exception as a 'PackageSetupException'
-wrapPackageSetupException :: IO a -> IO a
-wrapPackageSetupException = handleAny $ \case
-  e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE
-  e -> (throwIO . PackageSetupException . show) e
-
-showPackageSetupException :: PackageSetupException -> String
-showPackageSetupException GhcVersionMismatch{..} = unwords
-    ["ghcide compiled against GHC"
-    ,showVersion compileTime
-    ,"but currently using"
-    ,showVersion runTime
-    ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."
-    ]
-showPackageSetupException PackageSetupException{..} = unwords
-    [ "ghcide compiled by GHC", showVersion compilerVersion
-    , "failed to load packages:", message <> "."
-    , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
-showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords
-    ["ghcide compiled with package "
-    , packageName <> "-" <> showVersion compileTime
-    ,"but project uses package"
-    , packageName <> "-" <> showVersion runTime
-    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
-    ]
-showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords
-    ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi
-    ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi
-    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
-    ]
-
-renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
-renderPackageSetupException fp e =
-    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)
+{-# LANGUAGE TypeFamilies #-}++{-|+The logic for setting up a ghcide session by tapping into hie-bios.+-}+module Development.IDE.Session+  (SessionLoadingOptions(..)+  ,defaultLoadingOptions+  ,loadSession+  ,loadSessionWithOptions+  ) where++-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses+-- the real GHC library and the types are incompatible. Furthermore, when+-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!++import Control.Concurrent.Async+import Control.Concurrent.Extra+import Control.Exception.Safe+import Control.Monad+import Control.Monad.Extra+import Control.Monad.IO.Class+import qualified Crypto.Hash.SHA1 as H+import qualified Data.ByteString.Char8 as B+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Aeson+import Data.Bifunctor+import qualified Data.ByteString.Base16 as B16+import Data.Either.Extra+import Data.Function+import Data.Hashable+import Data.List+import Data.IORef+import Data.Maybe+import Data.Time.Clock+import Data.Version+import Development.IDE.Core.Shake+import Development.IDE.Core.RuleTypes+import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)+import qualified Development.IDE.GHC.Compat as GHC+import Development.IDE.GHC.Util+import Development.IDE.Session.VersionCheck+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Exports+import Development.IDE.Types.Location+import Development.IDE.Types.Logger+import Development.IDE.Types.Options+import Development.Shake (Action)+import GHC.Check+import qualified HIE.Bios as HieBios+import HIE.Bios.Environment hiding (getCacheDir)+import HIE.Bios.Types+import Hie.Implicit.Cradle (loadImplicitHieCradle)+import Language.Haskell.LSP.Core+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import System.Directory+import qualified System.Directory.Extra as IO+import System.FilePath+import System.Info+import System.IO++import GHCi+import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC)+import Linker+import Module+import NameCache+import Packages+import Control.Exception (evaluate)+import Data.Void+++data CacheDirs = CacheDirs+  { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}++data SessionLoadingOptions = SessionLoadingOptions+  { findCradle :: FilePath -> IO (Maybe FilePath)+  , loadCradle :: FilePath -> IO (HieBios.Cradle Void)+  -- | Given the project name and a set of command line flags,+  --   return the path for storing generated GHC artifacts,+  --   or 'Nothing' to respect the cradle setting+  , getCacheDirs :: String -> [String] -> IO CacheDirs+  }++defaultLoadingOptions :: SessionLoadingOptions+defaultLoadingOptions = SessionLoadingOptions+    {findCradle = HieBios.findCradle+    ,loadCradle = HieBios.loadCradle+    ,getCacheDirs = getCacheDirsDefault+    }++-- | Given a root directory, return a Shake 'Action' which setups an+-- 'IdeGhcSession' given a file.+-- Some of the many things this does:+--+-- * Find the cradle for the file+-- * Get the session options,+-- * Get the GHC lib directory+-- * Make sure the GHC compiletime and runtime versions match+-- * Restart the Shake session+--+-- This is the key function which implements multi-component support. All+-- components mapping to the same hie.yaml file are mapped to the same+-- HscEnv which is updated as new components are discovered.+loadSession :: FilePath -> IO (Action IdeGhcSession)+loadSession = loadSessionWithOptions defaultLoadingOptions++loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)+loadSessionWithOptions SessionLoadingOptions{..} dir = do+  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file+  hscEnvs <- newVar Map.empty :: IO (Var HieMap)+  -- Mapping from a Filepath to HscEnv+  fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)+  -- Version of the mappings above+  version <- newVar 0+  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)+  let invalidateShakeCache = do+        modifyVar_ version (return . succ)+  -- This caches the mapping from Mod.hs -> hie.yaml+  cradleLoc <- liftIO $ memoIO $ \v -> do+      res <- findCradle v+      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path+      -- try and normalise that+      -- e.g. see https://github.com/haskell/ghcide/issues/126+      res' <- traverse makeAbsolute res+      return $ normalise <$> res'++  dummyAs <- async $ return (error "Uninitialised")+  runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))++  return $ do+    extras@ShakeExtras{logger, eventer, restartShakeSession,+                       withIndefiniteProgress, ideNc, knownTargetsVar+                      } <- getShakeExtras++    IdeOptions{ optTesting = IdeTesting optTesting+              , optCheckProject = checkProject+              , optCustomDynFlags+              , optExtensions+              } <- getIdeOptions++        -- populate the knownTargetsVar with all the+        -- files in the project so that `knownFiles` can learn about them and+        -- we can generate a complete module graph+    let extendKnownTargets newTargets = do+          knownTargets <- forM newTargets $ \TargetDetails{..} ->+            case targetTarget of+              TargetFile f -> pure (targetTarget, [f])+              TargetModule _ -> do+                found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+                return (targetTarget, found)+          modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do+            let known' = HM.unionWith (<>) known $ HM.fromList knownTargets+            when (known /= known') $+                logDebug logger $ "Known files updated: " <>+                    T.pack(show $ (HM.map . map) fromNormalizedFilePath known')+            evaluate known'++    -- Create a new HscEnv from a hieYaml root and a set of options+    -- If the hieYaml file already has an HscEnv, the new component is+    -- combined with the components in the old HscEnv into a new HscEnv+    -- which contains the union.+    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)+                     -> IO (HscEnv, ComponentInfo, [ComponentInfo])+        packageSetup (hieYaml, cfp, opts, libDir) = do+          -- Parse DynFlags for the newly discovered component+          hscEnv <- emptyHscEnv ideNc libDir+          (df, targets) <- evalGhcEnv hscEnv $+              first optCustomDynFlags <$> 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+          -- or making a new one. The lookup returns the HscEnv and a list of+          -- information about other components loaded into the HscEnv+          -- (unitId, DynFlag, Targets)+          modifyVar hscEnvs $ \m -> do+              -- Just deps if there's already an HscEnv+              -- Nothing is it's the first time we are making an HscEnv+              let oldDeps = Map.lookup hieYaml m+              let -- Add the raw information about this component to the list+                  -- We will modify the unitId and DynFlags used for+                  -- compilation but these are the true source of+                  -- information.+                  new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info+                                : maybe [] snd oldDeps+                  -- Get all the unit-ids for things in this component+                  inplace = map rawComponentUnitId new_deps++              new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do+                  -- Remove all inplace dependencies from package flags for+                  -- components in this HscEnv+                  let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags+                  let prefix = show rawComponentUnitId+                  -- See Note [Avoiding bad interface files]+                  let hscComponents = sort $ map show uids+                      cacheDirOpts = hscComponents ++ componentOptions opts+                  cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts+                  processed_df <- setCacheDirs logger cacheDirs df2+                  -- The final component information, mostly the same but the DynFlags don't+                  -- contain any packages which are also loaded+                  -- into the same component.+                  pure $ ComponentInfo rawComponentUnitId+                                       processed_df+                                       uids+                                       rawComponentTargets+                                       rawComponentFP+                                       rawComponentCOptions+                                       rawComponentDependencyInfo+              -- Make a new HscEnv, we have to recompile everything from+              -- scratch again (for now)+              -- It's important to keep the same NameCache though for reasons+              -- that I do not fully understand+              logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))+              hscEnv <- emptyHscEnv ideNc libDir+              newHscEnv <-+                -- Add the options for the current component to the HscEnv+                evalGhcEnv hscEnv $ do+                  _ <- setSessionDynFlags df+                  getSession++              -- Modify the map so the hieYaml now maps to the newly created+              -- HscEnv+              -- Returns+              -- . the new HscEnv so it can be used to modify the+              --   FilePath -> HscEnv map (fileToFlags)+              -- . The information for the new component which caused this cache miss+              -- . The modified information (without -inplace flags) for+              --   existing packages+              pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))+++    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)+                -> IO (IdeResult HscEnvEq,[FilePath])+        session args@(hieYaml, _cfp, _opts, _libDir) = do+          (hscEnv, new, old_deps) <- packageSetup args++          -- Whenever we spin up a session on Linux, dynamically load libm.so.6+          -- in. We need this in case the binary is statically linked, in which+          -- case the interactive session will fail when trying to load+          -- ghc-prim, which happens whenever Template Haskell is being+          -- evaluated or haskell-language-server's eval plugin tries to run+          -- some code. If the binary is dynamically linked, then this will have+          -- no effect.+          -- See https://github.com/haskell/haskell-language-server/issues/221+          when (os == "linux") $ do+            initObjLinker hscEnv+            res <- loadDLL hscEnv "libm.so.6"+            case res of+              Nothing -> pure ()+              Just err -> hPutStrLn stderr $+                "Error dynamically loading libm.so.6:\n" <> err++          -- Make a map from unit-id to DynFlags, this is used when trying to+          -- resolve imports. (especially PackageImports)+          let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)++          -- For each component, now make a new HscEnvEq which contains the+          -- HscEnv for the hie.yaml file but the DynFlags for that component++          -- New HscEnv for the component in question, returns the new HscEnvEq and+          -- a mapping from FilePath to the newly created HscEnvEq.+          let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids+          (cs, res) <- new_cache new+          -- Modified cache targets for everything else in the hie.yaml file+          -- which now uses the same EPS and so on+          cached_targets <- concatMapM (fmap fst . new_cache) old_deps++          let all_targets = cs ++ cached_targets++          modifyVar_ fileToFlags $ \var -> do+              pure $ Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) var++          extendKnownTargets all_targets++          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session+          invalidateShakeCache+          restartShakeSession []++          -- Typecheck all files in the project on startup+          unless (null cs || not checkProject) $ do+                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)+                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do+                    mmt <- uses GetModificationTime cfps'+                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)+                    modIfaces <- uses GetModIface cs_exist+                    -- update exports map+                    extras <- getShakeExtras+                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces+                    liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)++          return (second Map.keys res)++    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])+        consultCradle hieYaml cfp = do+           lfp <- flip makeRelative cfp <$> getCurrentDirectory+           logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)++           when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp++           cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml++           when optTesting $ eventer $ notifyCradleLoaded lfp++           -- Display a user friendly progress message here: They probably don't know what a cradle is+           let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))+                         <> " (for " <> T.pack lfp <> ")"+           eopts <- withIndefiniteProgress progMsg NotCancellable $+             cradleToOptsAndLibDir cradle cfp++           logDebug logger $ T.pack ("Session loading result: " <> show eopts)+           case eopts of+             -- The cradle gave us some options so get to work turning them+             -- into and HscEnv.+             Right (opts, libDir) -> do+               installationCheck <- ghcVersionChecker libDir+               case installationCheck of+                 InstallationNotFound{..} ->+                     error $ "GHC installation not found in libdir: " <> libdir+                 InstallationMismatch{..} ->+                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])+                 InstallationChecked _compileTime _ghcLibCheck ->+                   session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)+             -- Failure case, either a cradle error or the none cradle+             Left err -> do+               dep_info <- getDependencyInfo (maybeToList hieYaml)+               let ncfp = toNormalizedFilePath' cfp+               let res = (map (renderCradleError ncfp) err, Nothing)+               modifyVar_ fileToFlags $ \var -> do+                 pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var+               return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)++    -- This caches the mapping from hie.yaml + Mod.hs -> [String]+    -- Returns the Ghc session and the cradle dependencies+    let sessionOpts :: (Maybe FilePath, FilePath)+                    -> IO (IdeResult HscEnvEq, [FilePath])+        sessionOpts (hieYaml, file) = do+          v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags+          cfp <- canonicalizePath file+          case HM.lookup (toNormalizedFilePath' cfp) v of+            Just (opts, old_di) -> do+              deps_ok <- checkDependencyInfo old_di+              if not deps_ok+                then do+                  -- If the dependencies are out of date then clear both caches and start+                  -- again.+                  modifyVar_ fileToFlags (const (return Map.empty))+                  -- Keep the same name cache+                  modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )+                  consultCradle hieYaml cfp+                else return (opts, Map.keys old_di)+            Nothing -> consultCradle hieYaml cfp++    -- The main function which gets options for a file. We only want one of these running+    -- at a time. Therefore the IORef contains the currently running cradle, if we try+    -- to get some more options then we wait for the currently running action to finish+    -- before attempting to do so.+    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])+        getOptions file = do+            hieYaml <- cradleLoc file+            sessionOpts (hieYaml, file) `catch` \e ->+                return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)++    returnWithVersion $ \file -> do+      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do+        -- If the cradle is not finished, then wait for it to finish.+        void $ wait as+        as <- async $ getOptions file+        return (as, wait as)+      pure opts++-- | Run the specific cradle on a specific FilePath via hie-bios.+-- This then builds dependencies or whatever based on the cradle, gets the+-- GHC options/dynflags needed for the session and the GHC library directory++cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath+                      -> IO (Either [CradleError] (ComponentOptions, FilePath))+cradleToOptsAndLibDir cradle file = do+    -- Start off by getting the session options+    let showLine s = hPutStrLn stderr ("> " ++ s)+    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle+    cradleRes <- runCradle (cradleOptsProg cradle) showLine file+    case cradleRes of+        CradleSuccess r -> do+            -- Now get the GHC lib dir+            libDirRes <- getRuntimeGhcLibDir cradle+            case libDirRes of+                -- This is the successful path+                CradleSuccess libDir -> pure (Right (r, libDir))+                CradleFail err -> return (Left [err])+                -- For the None cradle perhaps we still want to report an Info+                -- message about the fact that the file is being ignored.+                CradleNone -> return (Left [])++        CradleFail err -> return (Left [err])+        -- Same here+        CradleNone -> return (Left [])++emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv+emptyHscEnv nc libDir = do+    env <- runGhc (Just libDir) getSession+    initDynLinker env+    pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }++data TargetDetails = TargetDetails+  {+      targetTarget :: !Target,+      targetEnv :: !(IdeResult HscEnvEq),+      targetDepends :: !DependencyInfo,+      targetLocations :: ![NormalizedFilePath]+  }++fromTargetId :: [FilePath]          -- ^ import paths+             -> [String]            -- ^ extensions to consider+             -> TargetId+             -> IdeResult HscEnvEq+             -> DependencyInfo+             -> IO [TargetDetails]+-- For a target module we consider all the import paths+fromTargetId is exts (GHC.TargetModule mod) env dep = do+    let fps = [i </> moduleNameSlashes mod -<.> ext <> boot+              | ext <- exts+              , i <- is+              , boot <- ["", "-boot"]+              ]+    locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps+    return [TargetDetails (TargetModule mod) env dep locs]+-- For a 'TargetFile' we consider all the possible module names+fromTargetId _ _ (GHC.TargetFile f _) env deps = do+    nf <- toNormalizedFilePath' <$> canonicalizePath f+    return [TargetDetails (TargetFile nf) env deps [nf]]++toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]+toFlagsMap TargetDetails{..} =+    [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]+++setNameCache :: IORef NameCache -> HscEnv -> HscEnv+setNameCache nc hsc = hsc { hsc_NC = nc }++-- | Create a mapping from FilePaths to HscEnvEqs+newComponentCache+         :: Logger+         -> [String]       -- File extensions to consider+         -> Maybe FilePath -- Path to cradle+         -> NormalizedFilePath -- Path to file that caused the creation of this component+         -> HscEnv+         -> [(InstalledUnitId, DynFlags)]+         -> ComponentInfo+         -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))+newComponentCache logger exts cradlePath cfp hsc_env uids ci = do+    let df = componentDynFlags ci+    let hscEnv' = hsc_env { hsc_dflags = df+                          , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }++    let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath+    henv <- newFunc hscEnv' uids+    let targetEnv = ([], Just henv)+        targetDepends = componentDependencyInfo ci+        res = (targetEnv, targetDepends)+    logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))++    let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends+    ctargets <- concatMapM mk (componentTargets ci)++    -- A special target for the file which caused this wonderful+    -- component to be created. In case the cradle doesn't list all the targets for+    -- the component, in which case things will be horribly broken anyway.+    -- Otherwise, we will immediately attempt to reload this module which+    -- causes an infinite loop and high CPU usage.+    let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci]+    return (special_target:ctargets, res)++{- Note [Avoiding bad interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Originally, we set the cache directory for the various components once+on the first occurrence of the component.+This works fine if these components have no references to each other,+but you have components that depend on each other, the interface files are+updated for each component.+After restarting the session and only opening the component that depended+on the other, suddenly the interface files of this component are stale.+However, from the point of view of `ghcide`, they do not look stale,+thus, not regenerated and the IDE shows weird errors such as:+```+typecheckIface+Declaration for Rep_ClientRunFlags+Axiom branches Rep_ClientRunFlags:+  Failed to load interface for ‘Distribution.Simple.Flag’+  Use -v to see a list of the files searched for.+```+and+```+expectJust checkFamInstConsistency+CallStack (from HasCallStack):+  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes+  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst+```++To mitigate this, we set the cache directory for each component dependent+on the components of the current `HscEnv`, additionally to the component options+of the respective components.+Assume two components, c1, c2, where c2 depends on c1, and the options of the+respective components are co1, co2.+If we want to load component c2, followed by c1, we set the cache directory for+each component in this way:++  * Load component c2+    * (Cache Directory State)+        - name of c2 + co2+  * Load component c1+    * (Cache Directory State)+        - name of c2 + name of c1 + co2+        - name of c2 + name of c1 + co1++Overall, we created three cache directories. If we opened c1 first, then we+create a fourth cache directory.+This makes sure that interface files are always correctly updated.++Since this causes a lot of recompilation, we only update the cache-directory,+if the dependencies of a component have really changed.+E.g. when you load two executables, they can not depend on each other. They+should be filtered out, such that we dont have to re-compile everything.+-}++-- | Set the cache-directory based on the ComponentOptions and a list of+-- internal packages.+-- For the exact reason, see Note [Avoiding bad interface files].+setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags+setCacheDirs logger CacheDirs{..} dflags = do+    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir+    pure $ dflags+          & maybe id setHiDir hiCacheDir+          & maybe id setHieDir hieCacheDir+          & maybe id setODir oCacheDir+++renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic+renderCradleError nfp (CradleError _ _ec t) =+  ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t))++-- See Note [Multi Cradle Dependency Info]+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))++-- This is pristine information about a component+data RawComponentInfo = RawComponentInfo+  { rawComponentUnitId :: InstalledUnitId+  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.+  -- We do not want to use them unprocessed.+  , rawComponentDynFlags :: DynFlags+  -- | All targets of this components.+  , rawComponentTargets :: [GHC.Target]+  -- | Filepath which caused the creation of this component+  , rawComponentFP :: NormalizedFilePath+  -- | Component Options used to load the component.+  , rawComponentCOptions :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info].+  , rawComponentDependencyInfo :: DependencyInfo+  }++-- This is processed information about the component, in particular the dynflags will be modified.+data ComponentInfo = ComponentInfo+  { componentUnitId :: InstalledUnitId+  -- | Processed DynFlags. Does not contain inplace packages such as local+  -- libraries. Can be used to actually load this Component.+  , componentDynFlags :: DynFlags+  -- | Internal units, such as local libraries, that this component+  -- is loaded with. These have been extracted from the original+  -- ComponentOptions.+  , _componentInternalUnits :: [InstalledUnitId]+  -- | All targets of this components.+  , componentTargets :: [GHC.Target]+  -- | Filepath which caused the creation of this component+  , componentFP :: NormalizedFilePath+  -- | Component Options used to load the component.+  , _componentCOptions :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info]+  , componentDependencyInfo :: DependencyInfo+  }++-- | Check if any dependency has been modified lately.+checkDependencyInfo :: DependencyInfo -> IO Bool+checkDependencyInfo old_di = do+  di <- getDependencyInfo (Map.keys old_di)+  return (di == old_di)++-- Note [Multi Cradle Dependency Info]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why do we implement our own file modification tracking here?+-- The primary reason is that the custom caching logic is quite complicated and going into shake+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to+-- use shake rules rather than IO but eventually gave up.++-- | Computes a mapping from a filepath to its latest modification date.+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead+-- of letting shake take care of it.+getDependencyInfo :: [FilePath] -> IO DependencyInfo+getDependencyInfo fs = Map.fromList <$> mapM do_one fs++  where+    tryIO :: IO a -> IO (Either IOException a)+    tryIO = try++    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)+    do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)++-- | This function removes all the -package flags which refer to packages we+-- are going to deal with ourselves. For example, if a executable depends+-- on a library component, then this function will remove the library flag+-- from the package flags for the executable+--+-- There are several places in GHC (for example the call to hptInstances in+-- tcRnImports) which assume that all modules in the HPT have the same unit+-- ID. Therefore we create a fake one and give them all the same unit id.+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])+removeInplacePackages us df = (df { packageFlags = ps+                                  , thisInstalledUnitId = fake_uid }, uids)+  where+    (uids, ps) = partitionEithers (map go (packageFlags df))+    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")+    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us+                                                  then Left (toInstalledUnitId u)+                                                  else Right p+    go p = Right p++-- | Memoize an IO function, with the characteristics:+--+--   * If multiple people ask for a result simultaneously, make sure you only compute it once.+--+--   * If there are exceptions, repeatedly reraise them.+--+--   * If the caller is aborted (async exception) finish computing it anyway.+memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)+memoIO op = do+    ref <- newVar Map.empty+    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->+        case Map.lookup k mp of+            Nothing -> do+                res <- onceFork $ op k+                return (Map.insert k res mp, res)+            Just res -> return (mp, res)++-- | Throws if package flags are unsatisfiable+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target])+setOptions (ComponentOptions theOpts compRoot _) dflags = do+    (dflags', targets') <- addCmdOpts theOpts dflags+    let targets = makeTargetsAbsolute compRoot targets'+    let dflags'' =+          disableWarningsAsErrors $+          -- disabled, generated directly by ghcide instead+          flip gopt_unset Opt_WriteInterface $+          -- disabled, generated directly by ghcide instead+          -- also, it can confuse the interface stale check+          dontWriteHieFiles $+          setIgnoreInterfacePragmas $+          setLinkerOptions $+          disableOptimisation $+          setUpTypedHoles $+          makeDynFlagsAbsolute compRoot dflags'+    -- initPackages parses the -package flags and+    -- sets up the visibility for each component.+    -- Throws if a -package flag cannot be satisfied.+    (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''+    return (final_df, targets)+++-- we don't want to generate object code so we compile to bytecode+-- (HscInterpreted) which implies LinkInMemory+-- HscInterpreted+setLinkerOptions :: DynFlags -> DynFlags+setLinkerOptions df = df {+    ghcLink   = LinkInMemory+  , hscTarget = HscNothing+  , ghcMode = CompManager+  }++setIgnoreInterfacePragmas :: DynFlags -> DynFlags+setIgnoreInterfacePragmas df =+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges++disableOptimisation :: DynFlags -> DynFlags+disableOptimisation df = updOptLevel 0 df++setHiDir :: FilePath -> DynFlags -> DynFlags+setHiDir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { hiDir      = Just f}++setODir :: FilePath -> DynFlags -> DynFlags+setODir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { objectDir = Just f}++getCacheDirsDefault :: String -> [String] -> IO CacheDirs+getCacheDirsDefault prefix opts = do+    dir <- Just <$> getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)+    return $ CacheDirs dir dir dir+    where+        -- Create a unique folder per set of different GHC options, assuming that each different set of+        -- GHC options will create incompatible interface files.+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)++-- | Sub directory for the cache path+cacheDir :: String+cacheDir = "ghcide"++notifyUserImplicitCradle:: FilePath -> FromServerMessage+notifyUserImplicitCradle fp =+    NotShowMessage $+    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $+      "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "+      <> T.pack fp <>+      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\+      \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."++notifyCradleLoaded :: FilePath -> FromServerMessage+notifyCradleLoaded fp =+    NotCustomServer $+    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $+    toJSON fp++cradleLoadedMethod :: T.Text+cradleLoadedMethod = "ghcide/cradle/loaded"++----------------------------------------------------------------------------------------------------++data PackageSetupException+    = PackageSetupException+        { message     :: !String+        }+    | GhcVersionMismatch+        { compileTime :: !Version+        , runTime     :: !Version+        }+    | PackageCheckFailed !NotCompatibleReason+    deriving (Eq, Show, Typeable)++instance Exception PackageSetupException++-- | Wrap any exception as a 'PackageSetupException'+wrapPackageSetupException :: IO a -> IO a+wrapPackageSetupException = handleAny $ \case+  e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE+  e -> (throwIO . PackageSetupException . show) e++showPackageSetupException :: PackageSetupException -> String+showPackageSetupException GhcVersionMismatch{..} = unwords+    ["ghcide compiled against GHC"+    ,showVersion compileTime+    ,"but currently using"+    ,showVersion runTime+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."+    ]+showPackageSetupException PackageSetupException{..} = unwords+    [ "ghcide compiled by GHC", showVersion compilerVersion+    , "failed to load packages:", message <> "."+    , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]+showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords+    ["ghcide compiled with package "+    , packageName <> "-" <> showVersion compileTime+    ,"but project uses package"+    , packageName <> "-" <> showVersion runTime+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."+    ]+showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords+    ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi+    ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."+    ]++renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)+renderPackageSetupException fp e =+    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)
session-loader/Development/IDE/Session/VersionCheck.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE TemplateHaskell #-}
-
--- | This module exists to circumvent a compile time exception on Windows with
--- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session.
--- See https://github.com/haskell/ghcide/pull/697
-module Development.IDE.Session.VersionCheck (ghcVersionChecker) where
-
-import Data.Maybe
-import GHC.Check
--- Only use this for checking against the compile time GHC libDir!
--- Use getRuntimeGhcLibDir from hie-bios instead for everything else
--- otherwise binaries will not be distributable since paths will be baked into them
-import qualified GHC.Paths
-import System.Environment
-
-ghcVersionChecker :: GhcVersionChecker
-ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))
+{-# LANGUAGE TemplateHaskell #-}++-- | This module exists to circumvent a compile time exception on Windows with+-- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session.+-- See https://github.com/haskell/ghcide/pull/697+module Development.IDE.Session.VersionCheck (ghcVersionChecker) where++import Data.Maybe+import GHC.Check+-- Only use this for checking against the compile time GHC libDir!+-- Use getRuntimeGhcLibDir from hie-bios instead for everything else+-- otherwise binaries will not be distributable since paths will be baked into them+import qualified GHC.Paths+import System.Environment++ghcVersionChecker :: GhcVersionChecker+ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))
src/Development/IDE.hs view
@@ -1,45 +1,45 @@-module Development.IDE
-(
-    -- TODO It would be much nicer to enumerate all the exports
-    -- and organize them in sections
-    module X
-
-) where
-
-import Development.IDE.Core.RuleTypes as X
-import Development.IDE.Core.Rules as X
-  (getAtPoint
-  ,getClientConfigAction
-  ,getDefinition
-  ,getParsedModule
-  ,getTypeDefinition
-  )
-import Development.IDE.Core.FileExists as X
-  (getFileExists)
-import Development.IDE.Core.FileStore as X
-  (getFileContents)
-import Development.IDE.Core.IdeConfiguration as X
-  (IdeConfiguration(..)
-  ,isWorkspaceFile)
-import Development.IDE.Core.OfInterest as X (getFilesOfInterest)
-import Development.IDE.Core.Service as X (runAction)
-import Development.IDE.Core.Shake as X
-  ( IdeState,
-    shakeExtras,
-    ShakeExtras,
-    IdeRule,
-    define, defineEarlyCutoff,
-    use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',
-    FastResult(..),
-    use_, useNoFile_, uses_, useWithStale_,
-    ideLogger,
-    actionLogger,
-    IdeAction(..), runIdeAction
-  )
-import Development.IDE.GHC.Error as X
-import Development.IDE.GHC.Util as X
-import Development.IDE.Plugin as X
-import Development.IDE.Types.Diagnostics as X
-import Development.IDE.Types.Location as X
-import Development.IDE.Types.Logger as X
-import Development.Shake as X (Action, action, Rules, RuleResult)
+module Development.IDE+(+    -- TODO It would be much nicer to enumerate all the exports+    -- and organize them in sections+    module X++) where++import Development.IDE.Core.RuleTypes as X+import Development.IDE.Core.Rules as X+  (getAtPoint+  ,getClientConfigAction+  ,getDefinition+  ,getParsedModule+  ,getTypeDefinition+  )+import Development.IDE.Core.FileExists as X+  (getFileExists)+import Development.IDE.Core.FileStore as X+  (getFileContents)+import Development.IDE.Core.IdeConfiguration as X+  (IdeConfiguration(..)+  ,isWorkspaceFile)+import Development.IDE.Core.OfInterest as X (getFilesOfInterest)+import Development.IDE.Core.Service as X (runAction)+import Development.IDE.Core.Shake as X+  ( IdeState,+    shakeExtras,+    ShakeExtras,+    IdeRule,+    define, defineEarlyCutoff,+    use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',+    FastResult(..),+    use_, useNoFile_, uses_, useWithStale_,+    ideLogger,+    actionLogger,+    IdeAction(..), runIdeAction+  )+import Development.IDE.GHC.Error as X+import Development.IDE.GHC.Util as X+import Development.IDE.Plugin as X+import Development.IDE.Types.Diagnostics as X+import Development.IDE.Types.Location as X+import Development.IDE.Types.Logger as X+import Development.Shake as X (Action, action, Rules, RuleResult)
src/Development/IDE/Core/Compile.hs view
@@ -1,766 +1,835 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE CPP #-}
-#include "ghc-api-version.h"
-
--- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
---   Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
-module Development.IDE.Core.Compile
-  ( TcModuleResult(..)
-  , RunSimplifier(..)
-  , compileModule
-  , parseModule
-  , typecheckModule
-  , computePackageDeps
-  , addRelativeImport
-  , mkHiFileResultCompile
-  , mkHiFileResultNoCompile
-  , generateObjectCode
-  , generateByteCode
-  , generateHieAsts
-  , writeHieFile
-  , writeHiFile
-  , getModSummaryFromImports
-  , loadHieFile
-  , loadInterface
-  , loadModulesHome
-  , setupFinderCache
-  , getDocsBatch
-  , lookupName
-  ) where
-
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Core.Preprocessor
-import Development.IDE.Core.Shake
-import Development.IDE.GHC.Error
-import Development.IDE.GHC.Warnings
-import Development.IDE.Types.Diagnostics
-import Development.IDE.GHC.Orphans()
-import Development.IDE.GHC.Util
-import Development.IDE.Types.Options
-import Development.IDE.Types.Location
-
-import Language.Haskell.LSP.Types (DiagnosticTag(..))
-
-import LoadIface (loadModuleInterface)
-import DriverPhases
-import HscTypes
-import DriverPipeline hiding (unP)
-
-import qualified Parser
-import           Lexer
-#if MIN_GHC_API_VERSION(8,10,0)
-import Control.DeepSeq (force, rnf)
-#else
-import Control.DeepSeq (rnf)
-import ErrUtils
-#endif
-
-import           Finder
-import           Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile)
-import qualified Development.IDE.GHC.Compat     as GHC
-import qualified Development.IDE.GHC.Compat     as Compat
-import           GhcMonad
-import           GhcPlugins                     as GHC hiding (fst3, (<>))
-import           HscMain                        (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)
-import           MkIface
-import           StringBuffer                   as SB
-import           TcRnMonad
-import           TcIface                        (typecheckIface)
-import           TidyPgm
-
-import Control.Exception.Safe
-import Control.Monad.Extra
-import Control.Monad.Except
-import Control.Monad.Trans.Except
-import Data.Bifunctor                           (first, second)
-import qualified Data.ByteString as BS
-import qualified Data.Text as T
-import           Data.IORef
-import           Data.List.Extra
-import           Data.Maybe
-import qualified Data.Map.Strict                          as Map
-import           System.FilePath
-import           System.Directory
-import           System.IO.Extra
-import Control.Exception (evaluate)
-import TcEnv (tcLookup)
-import Data.Time (UTCTime, getCurrentTime)
-import Linker (unload)
-import qualified GHC.LanguageExtensions as LangExt
-import PrelNames
-import HeaderInfo
-import Maybes (orElse)
-
--- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
-parseModule
-    :: IdeOptions
-    -> HscEnv
-    -> FilePath
-    -> ModSummary
-    -> IO (IdeResult ParsedModule)
-parseModule IdeOptions{..} env filename ms =
-    fmap (either (, Nothing) id) $
-    runExceptT $ do
-        (diag, modu) <- parseFileContents env optPreprocessor filename ms
-        return (diag, Just modu)
-
-
--- | Given a package identifier, what packages does it depend on
-computePackageDeps
-    :: HscEnv
-    -> InstalledUnitId
-    -> IO (Either [FileDiagnostic] [InstalledUnitId])
-computePackageDeps env pkg = do
-    let dflags = hsc_dflags env
-    case lookupInstalledPackage dflags pkg of
-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
-            T.pack $ "unknown package: " ++ show pkg]
-        Just pkgInfo -> return $ Right $ depends pkgInfo
-
-typecheckModule :: IdeDefer
-                -> HscEnv
-                -> [Linkable] -- ^ linkables not to unload
-                -> ParsedModule
-                -> IO (IdeResult TcModuleResult)
-typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
-    fmap (either (,Nothing) id) $
-      catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
-
-        let modSummary = pm_mod_summary pm
-            dflags = ms_hspp_opts modSummary
-
-        modSummary' <- initPlugins hsc modSummary
-        (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
-            tcRnModule hsc keep_lbls $ enableTopLevelWarnings
-                                     $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
-        let errorPipeline = unDefer . hideDiag dflags . tagDiag
-            diags = map errorPipeline warnings
-            deferedError = any fst diags
-        return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})
-    where
-        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
-
-tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
-tcRnModule hsc_env keep_lbls pmod = do
-  let ms = pm_mod_summary pmod
-      hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
-
-  unload hsc_env_tmp keep_lbls
-  (tc_gbl_env, mrn_info) <-
-      hscTypecheckRename hsc_env_tmp ms $
-                HsParsedModule { hpm_module = parsedSource pmod,
-                                 hpm_src_files = pm_extra_src_files pmod,
-                                 hpm_annotations = pm_annotations pmod }
-  let rn_info = case mrn_info of
-        Just x -> x
-        Nothing -> error "no renamed info tcRnModule"
-  pure (TcModuleResult pmod rn_info tc_gbl_env False)
-
-mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
-mkHiFileResultNoCompile session tcm = do
-  let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms }
-      ms = pm_mod_summary $ tmrParsed tcm
-      tcGblEnv = tmrTypechecked tcm
-  details <- makeSimpleDetails hsc_env_tmp tcGblEnv
-  sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
-#if MIN_GHC_API_VERSION(8,10,0)
-  iface <- mkIfaceTc session sf details tcGblEnv
-#else
-  (iface, _) <- mkIfaceTc session Nothing sf details tcGblEnv
-#endif
-  let mod_info = HomeModInfo iface details Nothing
-  pure $! HiFileResult ms mod_info
-
-mkHiFileResultCompile
-    :: HscEnv
-    -> TcModuleResult
-    -> ModGuts
-    -> LinkableType -- ^ use object code or byte code?
-    -> IO (IdeResult HiFileResult)
-mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
-  let session = session' { hsc_dflags = ms_hspp_opts ms }
-      ms = pm_mod_summary $ tmrParsed tcm
-  -- give variables unique OccNames
-  (guts, details) <- tidyProgram session simplified_guts
-
-  let genLinkable = case ltype of
-        ObjectLinkable -> generateObjectCode
-        BCOLinkable -> generateByteCode
-
-  (diags, linkable) <- genLinkable session ms guts
-#if MIN_GHC_API_VERSION(8,10,0)
-  let !partial_iface = force (mkPartialIface session details simplified_guts)
-  final_iface <- mkFullIface session partial_iface
-#else
-  (final_iface,_) <- mkIface session Nothing details simplified_guts
-#endif
-  let mod_info = HomeModInfo final_iface details linkable
-  pure (diags, Just $! HiFileResult ms mod_info)
-
-  where
-    dflags = hsc_dflags session'
-    source = "compile"
-    catchErrs x = x `catches`
-      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-      , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
-      . (("Error during " ++ T.unpack source) ++) . show @SomeException
-      ]
-
-initPlugins :: HscEnv -> ModSummary -> IO ModSummary
-initPlugins session modSummary = do
-    dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary
-    return modSummary{ms_hspp_opts = dflags}
-
--- | Whether we should run the -O0 simplifier when generating core.
---
--- This is required for template Haskell to work but we disable this in DAML.
--- See #256
-newtype RunSimplifier = RunSimplifier Bool
-
--- | Compile a single type-checked module to a 'CoreModule' value, or
--- provide errors.
-compileModule
-    :: RunSimplifier
-    -> HscEnv
-    -> ModSummary
-    -> TcGblEnv
-    -> IO (IdeResult ModGuts)
-compileModule (RunSimplifier simplify) session ms tcg =
-    fmap (either (, Nothing) (second Just)) $
-        catchSrcErrors (hsc_dflags session) "compile" $ do
-            (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do
-               let ms' = tweak ms
-                   session' = session{ hsc_dflags = ms_hspp_opts ms'}
-               desugar <- hscDesugar session' ms' tcg
-               if simplify
-               then do
-                 plugins <- readIORef (tcg_th_coreplugins tcg)
-                 hscSimplify session' plugins desugar
-               else pure desugar
-            return (map snd warnings, desugared_guts)
-
-generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
-generateObjectCode session summary guts = do
-    fmap (either (, Nothing) (second Just)) $
-          catchSrcErrors (hsc_dflags session) "object" $ do
-              let dot_o =  ml_obj_file (ms_location summary)
-                  mod = ms_mod summary
-                  fp = replaceExtension dot_o "s"
-              createDirectoryIfMissing True (takeDirectory fp)
-              (warnings, dot_o_fp) <-
-                withWarnings "object" $ \_tweak -> do
-                      let summary' = _tweak summary
-                          session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}
-                      (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
-#if MIN_GHC_API_VERSION(8,10,0)
-                                (ms_location summary')
-#else
-                                summary'
-#endif
-                                fp
-                      compileFile session' StopLn (outputFilename, Just (As False))
-              let unlinked = DotO dot_o_fp
-              -- Need time to be the modification time for recompilation checking
-              t <- liftIO $ getModificationTime dot_o_fp
-              let linkable = LM t mod [unlinked]
-
-              pure (map snd warnings, linkable)
-
-generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
-generateByteCode hscEnv summary guts = do
-    fmap (either (, Nothing) (second Just)) $
-          catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do
-              (warnings, (_, bytecode, sptEntries)) <-
-                withWarnings "bytecode" $ \_tweak -> do
-                      let summary' = _tweak summary
-                          session = hscEnv { hsc_dflags = ms_hspp_opts summary' }
-                      hscInteractive session guts
-#if MIN_GHC_API_VERSION(8,10,0)
-                                (ms_location summary')
-#else
-                                summary'
-#endif
-              let unlinked = BCOs bytecode sptEntries
-              time <- liftIO getCurrentTime
-              let linkable = LM time (ms_mod summary) [unlinked]
-
-              pure (map snd warnings, linkable)
-
-demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
-demoteTypeErrorsToWarnings =
-  (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where
-
-  demoteTEsToWarns :: DynFlags -> DynFlags
-  -- convert the errors into warnings, and also check the warnings are enabled
-  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)
-                   . (`wopt_set` Opt_WarnTypedHoles)
-                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)
-                   . (`gopt_set` Opt_DeferTypeErrors)
-                   . (`gopt_set` Opt_DeferTypedHoles)
-                   . (`gopt_set` Opt_DeferOutOfScopeVariables)
-
-enableTopLevelWarnings :: ParsedModule -> ParsedModule
-enableTopLevelWarnings =
-  (update_pm_mod_summary . update_hspp_opts)
-  ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .
-   (`wopt_set` Opt_WarnMissingSignatures))
-  -- the line below would show also warnings for let bindings without signature
-  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))
-
-update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
-update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
-
-update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
-update_pm_mod_summary up pm =
-  pm{pm_mod_summary = up $ pm_mod_summary pm}
-
-unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)
-unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)
-unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)
-unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)
-unDefer ( _                                        , fd) = (False, fd)
-
-upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError (nfp, sh, fd) =
-  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
-  warn2err :: T.Text -> T.Text
-  warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
-
-hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
-hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
-  | not (wopt warning originalFlags)
-  = (Reason warning, (nfp, HideDiag, fd))
-hideDiag _originalFlags t = t
-
--- | Warnings which lead to a diagnostic tag
-unnecessaryDeprecationWarningFlags :: [WarningFlag]
-unnecessaryDeprecationWarningFlags
-  = [ Opt_WarnUnusedTopBinds
-    , Opt_WarnUnusedLocalBinds
-    , Opt_WarnUnusedPatternBinds
-    , Opt_WarnUnusedImports
-    , Opt_WarnUnusedMatches
-    , Opt_WarnUnusedTypePatterns
-    , Opt_WarnUnusedForalls
-#if MIN_GHC_API_VERSION(8,10,0)
-    , Opt_WarnUnusedRecordWildcards
-#endif
-    , Opt_WarnInaccessibleCode
-    , Opt_WarnWarningsDeprecations
-    ]
-
--- | Add a unnecessary/deprecated tag to the required diagnostics.
-tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
-tagDiag (Reason warning, (nfp, sh, fd))
-  | Just tag <- requiresTag warning
-  = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))
-  where
-    requiresTag :: WarningFlag -> Maybe DiagnosticTag
-    requiresTag Opt_WarnWarningsDeprecations
-      = Just DtDeprecated
-    requiresTag wflag  -- deprecation was already considered above
-      | wflag `elem` unnecessaryDeprecationWarningFlags
-      = Just DtUnnecessary
-    requiresTag _ = Nothing
-    addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)
-    addTag t Nothing          = Just (List [t])
-    addTag t (Just (List ts)) = Just (List (t : ts))
--- other diagnostics are left unaffected
-tagDiag t = t
-
-addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
-addRelativeImport fp modu dflags = dflags
-    {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
-
-atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
-atomicFileWrite targetPath write = do
-  let dir = takeDirectory targetPath
-  createDirectoryIfMissing True dir
-  (tempFilePath, cleanUp) <- newTempFileWithin dir
-  (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
-
-generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
-generateHieAsts hscEnv tcm =
-  handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $
-    Just <$> GHC.enrichHie (tcg_binds $ tmrTypechecked tcm) (tmrRenamed tcm)
-  where
-    dflags = hsc_dflags hscEnv
-
-writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
-writeHieFile hscEnv mod_summary exports ast source =
-  handleGenerationErrors dflags "extended interface write/compression" $ do
-    hf <- runHsc hscEnv $
-      GHC.mkHieFile' mod_summary exports ast source
-    atomicFileWrite targetPath $ flip GHC.writeHieFile hf
-  where
-    dflags       = hsc_dflags hscEnv
-    mod_location = ms_location mod_summary
-    targetPath   = Compat.ml_hie_file mod_location
-
-writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]
-writeHiFile hscEnv tc =
-  handleGenerationErrors dflags "interface generation" $ do
-    atomicFileWrite targetPath $ \fp ->
-      writeIfaceFile dflags fp modIface
-  where
-    modIface = hm_iface $ hirHomeMod tc
-    targetPath = ml_hi_file $ ms_location $ hirModSummary tc
-    dflags = hsc_dflags hscEnv
-
-handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
-handleGenerationErrors dflags source action =
-  action >> return [] `catches`
-    [ Handler $ return . diagFromGhcException source dflags
-    , Handler $ return . diagFromString source DsError (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
-    ]
-
-handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
-handleGenerationErrors' dflags source action =
-  fmap ([],) action `catches`
-    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
-    ]
-
--- | Initialise the finder cache, dependencies should be topologically
--- sorted.
-setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv
-setupFinderCache mss session = do
-
-    -- Make modules available for others that import them,
-    -- by putting them in the finder cache.
-    let ims  = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
-        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
-    -- set the target and module graph in the session
-        graph = mkModuleGraph mss
-
-    -- We have to create a new IORef here instead of modifying the existing IORef as
-    -- it is shared between concurrent compilations.
-    prevFinderCache <- readIORef $ hsc_FC session
-    let newFinderCache =
-            foldl'
-                (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache
-                $ zip ims ifrs
-    newFinderCacheVar <- newIORef $! newFinderCache
-
-    pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph }
-
-
--- | Load modules, quickly. Input doesn't need to be desugared.
--- A module must be loaded before dependent modules can be typechecked.
--- This variant of loadModuleHome will *never* cause recompilation, it just
--- modifies the session.
--- The order modules are loaded is important when there are hs-boot files.
--- In particular you should make sure to load the .hs version of a file after the
--- .hs-boot version.
-loadModulesHome
-    :: [HomeModInfo]
-    -> HscEnv
-    -> HscEnv
-loadModulesHome mod_infos e =
-    e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos]
-      , hsc_type_env_var = Nothing }
-    where
-      mod_name = moduleName . mi_module . hm_iface
-
-withBootSuffix :: HscSource -> ModLocation -> ModLocation
-withBootSuffix HsBootFile = addBootSuffixLocnOut
-withBootSuffix _ = id
-
--- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
---   Runs preprocessors as needed.
-getModSummaryFromImports
-  :: HscEnv
-  -> FilePath
-  -> UTCTime
-  -> Maybe SB.StringBuffer
-  -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs])
-getModSummaryFromImports env fp modTime contents = do
-    (contents, dflags) <- preprocessor env fp contents
-
-    -- The warns will hopefully be reported when we actually parse the module
-    (_warns, L main_loc hsmod) <- parseHeader dflags fp contents
-
-    -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports
-    let mb_mod = hsmodName hsmod
-        imps = hsmodImports hsmod
-
-        mod = fmap unLoc mb_mod `orElse` mAIN_NAME
-
-        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
-
-        -- GHC.Prim doesn't exist physically, so don't go looking for it.
-        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
-                                . ideclName . unLoc)
-                               ord_idecls
-
-        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
-        implicit_imports = mkPrelImports mod main_loc
-                                         implicit_prelude imps
-        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i)
-                                         , ideclName i)
-
-        srcImports = map convImport src_idecls
-        textualImports = map convImport (implicit_imports ++ ordinary_imps)
-
-        allImps = implicit_imports ++ imps
-
-    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
-    liftIO $ evaluate $ rnf srcImports
-    liftIO $ evaluate $ rnf textualImports
-
-    modLoc <- liftIO $ mkHomeModLocation dflags mod fp
-
-    let modl = mkModule (thisPackage dflags) mod
-        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
-        summary =
-            ModSummary
-                { ms_mod          = modl
-#if MIN_GHC_API_VERSION(8,8,0)
-                , ms_hie_date     = Nothing
-#endif
-                , ms_hs_date      = modTime
-                , ms_hsc_src      = sourceType
-                -- The contents are used by the GetModSummary rule
-                , ms_hspp_buf     = Just contents
-                , ms_hspp_file    = fp
-                , ms_hspp_opts    = dflags
-                , ms_iface_date   = Nothing
-                , ms_location     = withBootSuffix sourceType modLoc
-                , ms_obj_date     = Nothing
-                , ms_parsed_mod   = Nothing
-                , ms_srcimps      = srcImports
-                , ms_textual_imps = textualImports
-                }
-    return (summary, allImps)
-
--- | Parse only the module header
-parseHeader
-       :: Monad m
-       => DynFlags -- ^ flags to use
-       -> FilePath  -- ^ the filename (for source locations)
-       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
-       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
-parseHeader dflags filename contents = do
-   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
-   case unP Parser.parseHeader (mkPState dflags contents loc) of
-#if MIN_GHC_API_VERSION(8,10,0)
-     PFailed pst ->
-        throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
-#else
-     PFailed _ locErr msgErr ->
-        throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
-#endif
-     POk pst rdr_module -> do
-        let (warns, errs) = getMessages pst dflags
-        -- Just because we got a `POk`, it doesn't mean there
-        -- weren't errors! To clarify, the GHC parser
-        -- distinguishes between fatal and non-fatal
-        -- errors. Non-fatal errors are the sort that don't
-        -- prevent parsing from continuing (that is, a parse
-        -- tree can still be produced despite the error so that
-        -- further errors/warnings can be collected). Fatal
-        -- errors are those from which a parse tree just can't
-        -- be produced.
-        unless (null errs) $
-            throwE $ diagFromErrMsgs "parser" dflags errs
-
-        let warnings = diagFromErrMsgs "parser" dflags warns
-        return (warnings, rdr_module)
-
--- | Given a buffer, flags, and file path, produce a
--- parsed module (or errors) and any parse warnings. Does not run any preprocessors
--- ModSummary must contain the (preprocessed) contents of the buffer
-parseFileContents
-       :: HscEnv
-       -> (GHC.ParsedSource -> IdePreprocessedSource)
-       -> FilePath  -- ^ the filename (for source locations)
-       -> ModSummary
-       -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
-parseFileContents env customPreprocessor filename ms = do
-   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
-       dflags = ms_hspp_opts ms
-       contents = fromJust $ ms_hspp_buf ms
-   case unP Parser.parseModule (mkPState dflags contents loc) of
-#if MIN_GHC_API_VERSION(8,10,0)
-     PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
-#else
-     PFailed _ locErr msgErr ->
-      throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
-#endif
-     POk pst rdr_module ->
-         let hpm_annotations =
-               (Map.fromListWith (++) $ annotations pst,
-                 Map.fromList ((noSrcSpan,comment_q pst)
-                                  :annotations_comments pst))
-             (warns, errs) = getMessages pst dflags
-         in
-           do
-               -- Just because we got a `POk`, it doesn't mean there
-               -- weren't errors! To clarify, the GHC parser
-               -- distinguishes between fatal and non-fatal
-               -- errors. Non-fatal errors are the sort that don't
-               -- prevent parsing from continuing (that is, a parse
-               -- tree can still be produced despite the error so that
-               -- further errors/warnings can be collected). Fatal
-               -- errors are those from which a parse tree just can't
-               -- be produced.
-               unless (null errs) $
-                 throwE $ diagFromErrMsgs "parser" dflags errs
-
-               -- Ok, we got here. It's safe to continue.
-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
-
-               unless (null errs) $
-                  throwE $ diagFromStrings "parser" DsError errs
-
-               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
-
-               -- To get the list of extra source files, we take the list
-               -- that the parser gave us,
-               --   - eliminate files beginning with '<'.  gcc likes to use
-               --     pseudo-filenames like "<built-in>" and "<command-line>"
-               --   - normalise them (eliminate differences between ./f and f)
-               --   - filter out the preprocessed source file
-               --   - filter out anything beginning with tmpdir
-               --   - remove duplicates
-               --   - filter out the .hs/.lhs source filename if we have one
-               --
-               let n_hspp  = normalise filename
-                   srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))
-                                  $ filter (/= n_hspp)
-                                  $ map normalise
-                                  $ filter (not . isPrefixOf "<")
-                                  $ map unpackFS
-                                  $ srcfiles pst
-                   srcs1 = case ml_hs_file (ms_location ms) of
-                             Just f  -> filter (/= normalise f) srcs0
-                             Nothing -> srcs0
-
-               -- sometimes we see source files from earlier
-               -- preprocessing stages that cannot be found, so just
-               -- filter them out:
-               srcs2 <- liftIO $ filterM doesFileExist srcs1
-
-               let pm =
-                     ParsedModule {
-                         pm_mod_summary = ms
-                       , pm_parsed_source = parsed'
-                       , pm_extra_src_files = srcs2
-                       , pm_annotations = hpm_annotations
-                      }
-                   warnings = diagFromErrMsgs "parser" dflags warns
-               pure (warnings ++ preproc_warnings, pm)
-
-loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
-loadHieFile ncu f = do
-  GHC.hie_file_result <$> GHC.readHieFile ncu f
-
--- | Retuns an up-to-date module interface, regenerating if needed.
---   Assumes file exists.
---   Requires the 'HscEnv' to be set up with dependencies
-loadInterface
-  :: MonadIO m => HscEnv
-  -> ModSummary
-  -> SourceModified
-  -> Maybe LinkableType
-  -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface
-  -> m ([FileDiagnostic], Maybe HiFileResult)
-loadInterface session ms sourceMod linkableNeeded regen = do
-    res <- liftIO $ checkOldIface session ms sourceMod Nothing
-    case res of
-          (UpToDate, Just iface)
-            -- If the module used TH splices when it was last
-            -- compiled, then the recompilation check is not
-            -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)
-            -- and we must ignore
-            -- it.  However, if the module is stable (none of
-            -- the modules it depends on, directly or
-            -- indirectly, changed), then we *can* skip
-            -- recompilation. This is why the SourceModified
-            -- type contains SourceUnmodifiedAndStable, and
-            -- it's pretty important: otherwise ghc --make
-            -- would always recompile TH modules, even if
-            -- nothing at all has changed. Stability is just
-            -- the same check that make is doing for us in
-            -- one-shot mode.
-            | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod
-            -> do
-             linkable <- case linkableNeeded of
-               Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)
-               _ -> pure Nothing
-
-             -- We don't need to regenerate if the object is up do date, or we don't need one
-             let objUpToDate = isNothing linkableNeeded || case linkable of
-                   Nothing -> False
-                   Just (LM obj_time _ _) -> obj_time > ms_hs_date ms
-             if objUpToDate
-             then do
-               hmi <- liftIO $ mkDetailsFromIface session iface linkable
-               return ([], Just $ HiFileResult ms hmi)
-             else regen linkableNeeded
-          (_reason, _) -> regen linkableNeeded
-
-mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
-mkDetailsFromIface session iface linkable = do
-  details <- liftIO $ fixIO $ \details -> do
-    let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) }
-    initIfaceLoad hsc' (typecheckIface iface)
-  return (HomeModInfo iface details linkable)
-
--- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
---   The interactive paths create problems in ghc-lib builds
---- and leads to fun errors like "Cannot continue after interface file error".
-getDocsBatch
-  :: HscEnv
-  -> Module  -- ^ a moudle where the names are in scope
-  -> [Name]
-  -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)]
-getDocsBatch hsc_env _mod _names = do
-    ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->
-        case nameModule_maybe name of
-            Nothing -> return (Left $ NameHasNoModule name)
-            Just mod -> do
-             ModIface { mi_doc_hdr = mb_doc_hdr
-                      , mi_decl_docs = DeclDocMap dmap
-                      , mi_arg_docs = ArgDocMap amap
-                      } <- loadModuleInterface "getModuleInterface" mod
-             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
-               then pure (Left (NoDocsInIface mod $ compiled name))
-               else pure (Right ( Map.lookup name dmap
-                                , Map.findWithDefault Map.empty name amap))
-    case res of
-        Just x -> return $ map (first prettyPrint) x
-        Nothing -> throwErrors errs
-  where
-    throwErrors = liftIO . throwIO . mkSrcErr
-    compiled n =
-      -- TODO: Find a more direct indicator.
-      case nameSrcLoc n of
-        RealSrcLoc {} -> False
-        UnhelpfulLoc {} -> True
-
-fakeSpan :: RealSrcSpan
-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<ghcide>") 1 1
-
--- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
---   The interactive paths create problems in ghc-lib builds
---- and leads to fun errors like "Cannot continue after interface file error".
-lookupName :: HscEnv
-           -> Module -- ^ A module where the Names are in scope
-           -> Name
-           -> IO (Maybe TyThing)
-lookupName hsc_env mod name = do
-    (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do
-        tcthing <- tcLookup name
-        case tcthing of
-            AGlobal thing    -> return thing
-            ATcId{tct_id=id} -> return (AnId id)
-            _ -> panic "tcRnLookupName'"
-    return res
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"++-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.+--   Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.+module Development.IDE.Core.Compile+  ( TcModuleResult(..)+  , RunSimplifier(..)+  , compileModule+  , parseModule+  , typecheckModule+  , computePackageDeps+  , addRelativeImport+  , mkHiFileResultCompile+  , mkHiFileResultNoCompile+  , generateObjectCode+  , generateByteCode+  , generateHieAsts+  , writeHieFile+  , writeHiFile+  , getModSummaryFromImports+  , loadHieFile+  , loadInterface+  , loadModulesHome+  , setupFinderCache+  , getDocsBatch+  , lookupName+  ) where++import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Preprocessor+import Development.IDE.Core.Shake+import Development.IDE.GHC.Error+import Development.IDE.GHC.Warnings+import Development.IDE.Types.Diagnostics+import Development.IDE.GHC.Orphans()+import Development.IDE.GHC.Util+import Development.IDE.Types.Options+import Development.IDE.Types.Location++import Language.Haskell.LSP.Types (DiagnosticTag(..))++import LoadIface (loadModuleInterface)+import DriverPhases+import HscTypes+import DriverPipeline hiding (unP)++import qualified Parser+import           Lexer+#if MIN_GHC_API_VERSION(8,10,0)+import Control.DeepSeq (force, rnf)+#else+import Control.DeepSeq (rnf)+import ErrUtils+#endif++import           Finder+import           Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile)+import qualified Development.IDE.GHC.Compat     as GHC+import qualified Development.IDE.GHC.Compat     as Compat+import           GhcMonad+import           GhcPlugins                     as GHC hiding (fst3, (<>))+import           HscMain                        (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)+import           MkIface+import           StringBuffer                   as SB+import           TcRnMonad+import           TcIface                        (typecheckIface)+import           TidyPgm+import           Hooks+import           TcSplice++import Control.Exception.Safe+import Control.Lens hiding (List)+import Control.Monad.Extra+import Control.Monad.Except+import Control.Monad.Trans.Except+import Data.Bifunctor                           (first, second)+import qualified Data.ByteString as BS+import qualified Data.Text as T+import           Data.IORef+import           Data.List.Extra+import           Data.Maybe+import qualified Data.Map.Strict                          as Map+import           System.FilePath+import           System.Directory+import System.IO.Extra ( fixIO, newTempFileWithin )+import Control.Exception (evaluate)+import TcEnv (tcLookup)+import qualified Data.DList as DL+import Data.Time (UTCTime, getCurrentTime)+import Bag+import Linker (unload)+import qualified GHC.LanguageExtensions as LangExt+import PrelNames+import HeaderInfo+import Maybes (orElse)++-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.+parseModule+    :: IdeOptions+    -> HscEnv+    -> FilePath+    -> ModSummary+    -> IO (IdeResult ParsedModule)+parseModule IdeOptions{..} env filename ms =+    fmap (either (, Nothing) id) $+    runExceptT $ do+        (diag, modu) <- parseFileContents env optPreprocessor filename ms+        return (diag, Just modu)+++-- | Given a package identifier, what packages does it depend on+computePackageDeps+    :: HscEnv+    -> InstalledUnitId+    -> IO (Either [FileDiagnostic] [InstalledUnitId])+computePackageDeps env pkg = do+    let dflags = hsc_dflags env+    case lookupInstalledPackage dflags pkg of+        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $+            T.pack $ "unknown package: " ++ show pkg]+        Just pkgInfo -> return $ Right $ depends pkgInfo++typecheckModule :: IdeDefer+                -> HscEnv+                -> [Linkable] -- ^ linkables not to unload+                -> ParsedModule+                -> IO (IdeResult TcModuleResult)+typecheckModule (IdeDefer defer) hsc keep_lbls pm = do+    fmap (either (,Nothing) id) $+      catchSrcErrors (hsc_dflags hsc) "typecheck" $ do++        let modSummary = pm_mod_summary pm+            dflags = ms_hspp_opts modSummary++        modSummary' <- initPlugins hsc modSummary+        (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->+            tcRnModule hsc keep_lbls $ enableTopLevelWarnings+                                     $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}+        let errorPipeline = unDefer . hideDiag dflags . tagDiag+            diags = map errorPipeline warnings+            deferedError = any fst diags+        return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})+    where+        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id++-- | Add a Hook to the DynFlags which captures and returns the+-- typechecked splices before they are run. This information+-- is used for hover.+captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)+captureSplices dflags k = do+  splice_ref <- newIORef mempty+  res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)})+  splices <- readIORef splice_ref+  return (res, splices)+  where+    addSpliceHook :: IORef Splices -> Hooks -> Hooks+    addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) }++    splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM+    splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of+        (MetaE f) -> do+            expr' <- metaRequestE hook e+            liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :)+            pure $ f expr'+        (MetaP f) -> do+            pat' <- metaRequestP hook e+            liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :)+            pure $ f pat'+        (MetaT f) -> do+            type' <- metaRequestT hook e+            liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :)+            pure $ f type'+        (MetaD f) -> do+            decl' <- metaRequestD hook e+            liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :)+            pure $ f decl'+        (MetaAW f) -> do+            aw' <- metaRequestAW hook e+            liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :)+            pure $ f aw'+++tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult+tcRnModule hsc_env keep_lbls pmod = do+  let ms = pm_mod_summary pmod+      hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }++  unload hsc_env_tmp keep_lbls++  ((tc_gbl_env, mrn_info), splices)+      <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags ->+             do  let hsc_env_tmp = hsc_env { hsc_dflags = dflags }+                 hscTypecheckRename hsc_env_tmp ms $+                          HsParsedModule { hpm_module = parsedSource pmod,+                                           hpm_src_files = pm_extra_src_files pmod,+                                           hpm_annotations = pm_annotations pmod }+  let rn_info = case mrn_info of+        Just x -> x+        Nothing -> error "no renamed info tcRnModule"+  pure (TcModuleResult pmod rn_info tc_gbl_env splices False)++mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult+mkHiFileResultNoCompile session tcm = do+  let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms }+      ms = pm_mod_summary $ tmrParsed tcm+      tcGblEnv = tmrTypechecked tcm+  details <- makeSimpleDetails hsc_env_tmp tcGblEnv+  sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv+#if MIN_GHC_API_VERSION(8,10,0)+  iface <- mkIfaceTc session sf details tcGblEnv+#else+  (iface, _) <- mkIfaceTc session Nothing sf details tcGblEnv+#endif+  let mod_info = HomeModInfo iface details Nothing+  pure $! HiFileResult ms mod_info++mkHiFileResultCompile+    :: HscEnv+    -> TcModuleResult+    -> ModGuts+    -> LinkableType -- ^ use object code or byte code?+    -> IO (IdeResult HiFileResult)+mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do+  let session = session' { hsc_dflags = ms_hspp_opts ms }+      ms = pm_mod_summary $ tmrParsed tcm+      tcGblEnv = tmrTypechecked tcm++  let genLinkable = case ltype of+        ObjectLinkable -> generateObjectCode+        BCOLinkable -> generateByteCode++  (linkable, details, diags) <-+    if mg_hsc_src simplified_guts == HsBootFile+    then do+        -- give variables unique OccNames+        details <- mkBootModDetailsTc session tcGblEnv+        pure (Nothing, details, [])+    else do+        -- give variables unique OccNames+        (guts, details) <- tidyProgram session simplified_guts+        (diags, linkable) <- genLinkable session ms guts+        pure (linkable, details, diags)+#if MIN_GHC_API_VERSION(8,10,0)+  let !partial_iface = force (mkPartialIface session details simplified_guts)+  final_iface <- mkFullIface session partial_iface+#else+  (final_iface,_) <- mkIface session Nothing details simplified_guts+#endif+  let mod_info = HomeModInfo final_iface details linkable+  pure (diags, Just $! HiFileResult ms mod_info)++  where+    dflags = hsc_dflags session'+    source = "compile"+    catchErrs x = x `catches`+      [ Handler $ return . (,Nothing) . diagFromGhcException source dflags+      , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")+      . (("Error during " ++ T.unpack source) ++) . show @SomeException+      ]++initPlugins :: HscEnv -> ModSummary -> IO ModSummary+initPlugins session modSummary = do+    dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary+    return modSummary{ms_hspp_opts = dflags}++-- | Whether we should run the -O0 simplifier when generating core.+--+-- This is required for template Haskell to work but we disable this in DAML.+-- See #256+newtype RunSimplifier = RunSimplifier Bool++-- | Compile a single type-checked module to a 'CoreModule' value, or+-- provide errors.+compileModule+    :: RunSimplifier+    -> HscEnv+    -> ModSummary+    -> TcGblEnv+    -> IO (IdeResult ModGuts)+compileModule (RunSimplifier simplify) session ms tcg =+    fmap (either (, Nothing) (second Just)) $+        catchSrcErrors (hsc_dflags session) "compile" $ do+            (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do+               let ms' = tweak ms+                   session' = session{ hsc_dflags = ms_hspp_opts ms'}+               desugar <- hscDesugar session' ms' tcg+               if simplify+               then do+                 plugins <- readIORef (tcg_th_coreplugins tcg)+                 hscSimplify session' plugins desugar+               else pure desugar+            return (map snd warnings, desugared_guts)++generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateObjectCode session summary guts = do+    fmap (either (, Nothing) (second Just)) $+          catchSrcErrors (hsc_dflags session) "object" $ do+              let dot_o =  ml_obj_file (ms_location summary)+                  mod = ms_mod summary+                  fp = replaceExtension dot_o "s"+              createDirectoryIfMissing True (takeDirectory fp)+              (warnings, dot_o_fp) <-+                withWarnings "object" $ \_tweak -> do+                      let summary' = _tweak summary+                          session' = session { hsc_dflags = (ms_hspp_opts summary') { outputFile = Just dot_o }}+                      (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts+#if MIN_GHC_API_VERSION(8,10,0)+                                (ms_location summary')+#else+                                summary'+#endif+                                fp+                      compileFile session' StopLn (outputFilename, Just (As False))+              let unlinked = DotO dot_o_fp+              -- Need time to be the modification time for recompilation checking+              t <- liftIO $ getModificationTime dot_o_fp+              let linkable = LM t mod [unlinked]++              pure (map snd warnings, linkable)++generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateByteCode hscEnv summary guts = do+    fmap (either (, Nothing) (second Just)) $+          catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do+              (warnings, (_, bytecode, sptEntries)) <-+                withWarnings "bytecode" $ \_tweak -> do+                      let summary' = _tweak summary+                          session = hscEnv { hsc_dflags = ms_hspp_opts summary' }+                      hscInteractive session guts+#if MIN_GHC_API_VERSION(8,10,0)+                                (ms_location summary')+#else+                                summary'+#endif+              let unlinked = BCOs bytecode sptEntries+              time <- liftIO getCurrentTime+              let linkable = LM time (ms_mod summary) [unlinked]++              pure (map snd warnings, linkable)++demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule+demoteTypeErrorsToWarnings =+  (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where++  demoteTEsToWarns :: DynFlags -> DynFlags+  -- convert the errors into warnings, and also check the warnings are enabled+  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)+                   . (`wopt_set` Opt_WarnTypedHoles)+                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)+                   . (`gopt_set` Opt_DeferTypeErrors)+                   . (`gopt_set` Opt_DeferTypedHoles)+                   . (`gopt_set` Opt_DeferOutOfScopeVariables)++enableTopLevelWarnings :: ParsedModule -> ParsedModule+enableTopLevelWarnings =+  (update_pm_mod_summary . update_hspp_opts)+  ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .+   (`wopt_set` Opt_WarnMissingSignatures))+  -- the line below would show also warnings for let bindings without signature+  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))++update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary+update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}++update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule+update_pm_mod_summary up pm =+  pm{pm_mod_summary = up $ pm_mod_summary pm}++unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic)+unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd)+unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd)+unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)+unDefer ( _                                        , fd) = (False, fd)++upgradeWarningToError :: FileDiagnostic -> FileDiagnostic+upgradeWarningToError (nfp, sh, fd) =+  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where+  warn2err :: T.Text -> T.Text+  warn2err = T.intercalate ": error:" . T.splitOn ": warning:"++hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))+  | not (wopt warning originalFlags)+  = (Reason warning, (nfp, HideDiag, fd))+hideDiag _originalFlags t = t++-- | Warnings which lead to a diagnostic tag+unnecessaryDeprecationWarningFlags :: [WarningFlag]+unnecessaryDeprecationWarningFlags+  = [ Opt_WarnUnusedTopBinds+    , Opt_WarnUnusedLocalBinds+    , Opt_WarnUnusedPatternBinds+    , Opt_WarnUnusedImports+    , Opt_WarnUnusedMatches+    , Opt_WarnUnusedTypePatterns+    , Opt_WarnUnusedForalls+#if MIN_GHC_API_VERSION(8,10,0)+    , Opt_WarnUnusedRecordWildcards+#endif+    , Opt_WarnInaccessibleCode+    , Opt_WarnWarningsDeprecations+    ]++-- | Add a unnecessary/deprecated tag to the required diagnostics.+tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)+tagDiag (Reason warning, (nfp, sh, fd))+  | Just tag <- requiresTag warning+  = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))+  where+    requiresTag :: WarningFlag -> Maybe DiagnosticTag+    requiresTag Opt_WarnWarningsDeprecations+      = Just DtDeprecated+    requiresTag wflag  -- deprecation was already considered above+      | wflag `elem` unnecessaryDeprecationWarningFlags+      = Just DtUnnecessary+    requiresTag _ = Nothing+    addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)+    addTag t Nothing          = Just (List [t])+    addTag t (Just (List ts)) = Just (List (t : ts))+-- other diagnostics are left unaffected+tagDiag t = t++addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags+addRelativeImport fp modu dflags = dflags+    {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}++atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()+atomicFileWrite targetPath write = do+  let dir = takeDirectory targetPath+  createDirectoryIfMissing True dir+  (tempFilePath, cleanUp) <- newTempFileWithin dir+  (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp++generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))+generateHieAsts hscEnv tcm =+  handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do+    -- These varBinds use unitDataConId but it could be anything as the id name is not used+    -- during the hie file generation process. It's a workaround for the fact that the hie modules+    -- don't export an interface which allows for additional information to be added to hie files.+    let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))+        real_binds = tcg_binds $ tmrTypechecked tcm+    Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm)+  where+    dflags = hsc_dflags hscEnv++spliceExpresions :: Splices -> [LHsExpr GhcTc]+spliceExpresions Splices{..} =+    DL.toList $ mconcat+        [ DL.fromList $ map fst exprSplices+        , DL.fromList $ map fst patSplices+        , DL.fromList $ map fst typeSplices+        , DL.fromList $ map fst declSplices+        , DL.fromList $ map fst awSplices+        ]++writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]+writeHieFile hscEnv mod_summary exports ast source =+  handleGenerationErrors dflags "extended interface write/compression" $ do+    hf <- runHsc hscEnv $+      GHC.mkHieFile' mod_summary exports ast source+    atomicFileWrite targetPath $ flip GHC.writeHieFile hf+  where+    dflags       = hsc_dflags hscEnv+    mod_location = ms_location mod_summary+    targetPath   = Compat.ml_hie_file mod_location++writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]+writeHiFile hscEnv tc =+  handleGenerationErrors dflags "interface generation" $ do+    atomicFileWrite targetPath $ \fp ->+      writeIfaceFile dflags fp modIface+  where+    modIface = hm_iface $ hirHomeMod tc+    targetPath = ml_hi_file $ ms_location $ hirModSummary tc+    dflags = hsc_dflags hscEnv++handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]+handleGenerationErrors dflags source action =+  action >> return [] `catches`+    [ Handler $ return . diagFromGhcException source dflags+    , Handler $ return . diagFromString source DsError (noSpan "<internal>")+    . (("Error during " ++ T.unpack source) ++) . show @SomeException+    ]++handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)+handleGenerationErrors' dflags source action =+  fmap ([],) action `catches`+    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags+    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")+    . (("Error during " ++ T.unpack source) ++) . show @SomeException+    ]++-- | Initialise the finder cache, dependencies should be topologically+-- sorted.+setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv+setupFinderCache mss session = do++    -- Make modules available for others that import them,+    -- by putting them in the finder cache.+    let ims  = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss+        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims+    -- set the target and module graph in the session+        graph = mkModuleGraph mss++    -- We have to create a new IORef here instead of modifying the existing IORef as+    -- it is shared between concurrent compilations.+    prevFinderCache <- readIORef $ hsc_FC session+    let newFinderCache =+            foldl'+                (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache+                $ zip ims ifrs+    newFinderCacheVar <- newIORef $! newFinderCache++    pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph }+++-- | Load modules, quickly. Input doesn't need to be desugared.+-- A module must be loaded before dependent modules can be typechecked.+-- This variant of loadModuleHome will *never* cause recompilation, it just+-- modifies the session.+-- The order modules are loaded is important when there are hs-boot files.+-- In particular you should make sure to load the .hs version of a file after the+-- .hs-boot version.+loadModulesHome+    :: [HomeModInfo]+    -> HscEnv+    -> HscEnv+loadModulesHome mod_infos e =+    e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos]+      , hsc_type_env_var = Nothing }+    where+      mod_name = moduleName . mi_module . hm_iface++withBootSuffix :: HscSource -> ModLocation -> ModLocation+withBootSuffix HsBootFile = addBootSuffixLocnOut+withBootSuffix _ = id++-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.+--   Runs preprocessors as needed.+getModSummaryFromImports+  :: HscEnv+  -> FilePath+  -> UTCTime+  -> Maybe SB.StringBuffer+  -> ExceptT [FileDiagnostic] IO (ModSummary,[LImportDecl GhcPs])+getModSummaryFromImports env fp modTime contents = do+    (contents, dflags) <- preprocessor env fp contents++    -- The warns will hopefully be reported when we actually parse the module+    (_warns, L main_loc hsmod) <- parseHeader dflags fp contents++    -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports+    let mb_mod = hsmodName hsmod+        imps = hsmodImports hsmod++        mod = fmap unLoc mb_mod `orElse` mAIN_NAME++        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps++        -- GHC.Prim doesn't exist physically, so don't go looking for it.+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc+                                . ideclName . unLoc)+                               ord_idecls++        implicit_prelude = xopt LangExt.ImplicitPrelude dflags+        implicit_imports = mkPrelImports mod main_loc+                                         implicit_prelude imps+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i)+                                         , ideclName i)++        srcImports = map convImport src_idecls+        textualImports = map convImport (implicit_imports ++ ordinary_imps)++        allImps = implicit_imports ++ imps++    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily+    liftIO $ evaluate $ rnf srcImports+    liftIO $ evaluate $ rnf textualImports++    modLoc <- liftIO $ mkHomeModLocation dflags mod fp++    let modl = mkModule (thisPackage dflags) mod+        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile+        summary =+            ModSummary+                { ms_mod          = modl+#if MIN_GHC_API_VERSION(8,8,0)+                , ms_hie_date     = Nothing+#endif+                , ms_hs_date      = modTime+                , ms_hsc_src      = sourceType+                -- The contents are used by the GetModSummary rule+                , ms_hspp_buf     = Just contents+                , ms_hspp_file    = fp+                , ms_hspp_opts    = dflags+                , ms_iface_date   = Nothing+                , ms_location     = withBootSuffix sourceType modLoc+                , ms_obj_date     = Nothing+                , ms_parsed_mod   = Nothing+                , ms_srcimps      = srcImports+                , ms_textual_imps = textualImports+                }+    return (summary, allImps)++-- | Parse only the module header+parseHeader+       :: Monad m+       => DynFlags -- ^ flags to use+       -> FilePath  -- ^ the filename (for source locations)+       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)+       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))+parseHeader dflags filename contents = do+   let loc  = mkRealSrcLoc (mkFastString filename) 1 1+   case unP Parser.parseHeader (mkPState dflags contents loc) of+#if MIN_GHC_API_VERSION(8,10,0)+     PFailed pst ->+        throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags+#else+     PFailed _ locErr msgErr ->+        throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr+#endif+     POk pst rdr_module -> do+        let (warns, errs) = getMessages pst dflags+        -- Just because we got a `POk`, it doesn't mean there+        -- weren't errors! To clarify, the GHC parser+        -- distinguishes between fatal and non-fatal+        -- errors. Non-fatal errors are the sort that don't+        -- prevent parsing from continuing (that is, a parse+        -- tree can still be produced despite the error so that+        -- further errors/warnings can be collected). Fatal+        -- errors are those from which a parse tree just can't+        -- be produced.+        unless (null errs) $+            throwE $ diagFromErrMsgs "parser" dflags errs++        let warnings = diagFromErrMsgs "parser" dflags warns+        return (warnings, rdr_module)++-- | Given a buffer, flags, and file path, produce a+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors+-- ModSummary must contain the (preprocessed) contents of the buffer+parseFileContents+       :: HscEnv+       -> (GHC.ParsedSource -> IdePreprocessedSource)+       -> FilePath  -- ^ the filename (for source locations)+       -> ModSummary+       -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)+parseFileContents env customPreprocessor filename ms = do+   let loc  = mkRealSrcLoc (mkFastString filename) 1 1+       dflags = ms_hspp_opts ms+       contents = fromJust $ ms_hspp_buf ms+   case unP Parser.parseModule (mkPState dflags contents loc) of+#if MIN_GHC_API_VERSION(8,10,0)+     PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags+#else+     PFailed _ locErr msgErr ->+      throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr+#endif+     POk pst rdr_module ->+         let hpm_annotations =+               (Map.fromListWith (++) $ annotations pst,+                 Map.fromList ((noSrcSpan,comment_q pst)+                                  :annotations_comments pst))+             (warns, errs) = getMessages pst dflags+         in+           do+               -- Just because we got a `POk`, it doesn't mean there+               -- weren't errors! To clarify, the GHC parser+               -- distinguishes between fatal and non-fatal+               -- errors. Non-fatal errors are the sort that don't+               -- prevent parsing from continuing (that is, a parse+               -- tree can still be produced despite the error so that+               -- further errors/warnings can be collected). Fatal+               -- errors are those from which a parse tree just can't+               -- be produced.+               unless (null errs) $+                 throwE $ diagFromErrMsgs "parser" dflags errs++               -- Ok, we got here. It's safe to continue.+               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module++               unless (null errs) $+                  throwE $ diagFromStrings "parser" DsError errs++               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns+               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed++               -- To get the list of extra source files, we take the list+               -- that the parser gave us,+               --   - eliminate files beginning with '<'.  gcc likes to use+               --     pseudo-filenames like "<built-in>" and "<command-line>"+               --   - normalise them (eliminate differences between ./f and f)+               --   - filter out the preprocessed source file+               --   - filter out anything beginning with tmpdir+               --   - remove duplicates+               --   - filter out the .hs/.lhs source filename if we have one+               --+               let n_hspp  = normalise filename+                   srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))+                                  $ filter (/= n_hspp)+                                  $ map normalise+                                  $ filter (not . isPrefixOf "<")+                                  $ map unpackFS+                                  $ srcfiles pst+                   srcs1 = case ml_hs_file (ms_location ms) of+                             Just f  -> filter (/= normalise f) srcs0+                             Nothing -> srcs0++               -- sometimes we see source files from earlier+               -- preprocessing stages that cannot be found, so just+               -- filter them out:+               srcs2 <- liftIO $ filterM doesFileExist srcs1++               let pm =+                     ParsedModule {+                         pm_mod_summary = ms+                       , pm_parsed_source = parsed'+                       , pm_extra_src_files = srcs2+                       , pm_annotations = hpm_annotations+                      }+                   warnings = diagFromErrMsgs "parser" dflags warns+               pure (warnings ++ preproc_warnings, pm)++loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile+loadHieFile ncu f = do+  GHC.hie_file_result <$> GHC.readHieFile ncu f++-- | Retuns an up-to-date module interface, regenerating if needed.+--   Assumes file exists.+--   Requires the 'HscEnv' to be set up with dependencies+loadInterface+  :: MonadIO m => HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe LinkableType+  -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface+  -> m ([FileDiagnostic], Maybe HiFileResult)+loadInterface session ms sourceMod linkableNeeded regen = do+    res <- liftIO $ checkOldIface session ms sourceMod Nothing+    case res of+          (UpToDate, Just iface)+            -- If the module used TH splices when it was last+            -- compiled, then the recompilation check is not+            -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481)+            -- and we must ignore+            -- it.  However, if the module is stable (none of+            -- the modules it depends on, directly or+            -- indirectly, changed), then we *can* skip+            -- recompilation. This is why the SourceModified+            -- type contains SourceUnmodifiedAndStable, and+            -- it's pretty important: otherwise ghc --make+            -- would always recompile TH modules, even if+            -- nothing at all has changed. Stability is just+            -- the same check that make is doing for us in+            -- one-shot mode.+            | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod+            -> do+             linkable <- case linkableNeeded of+               Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)+               _ -> pure Nothing++             -- We don't need to regenerate if the object is up do date, or we don't need one+             let objUpToDate = isNothing linkableNeeded || case linkable of+                   Nothing -> False+                   Just (LM obj_time _ _) -> obj_time > ms_hs_date ms+             if objUpToDate+             then do+               hmi <- liftIO $ mkDetailsFromIface session iface linkable+               return ([], Just $ HiFileResult ms hmi)+             else regen linkableNeeded+          (_reason, _) -> regen linkableNeeded++mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo+mkDetailsFromIface session iface linkable = do+  details <- liftIO $ fixIO $ \details -> do+    let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) }+    initIfaceLoad hsc' (typecheckIface iface)+  return (HomeModInfo iface details linkable)++-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.+--   The interactive paths create problems in ghc-lib builds+--- and leads to fun errors like "Cannot continue after interface file error".+getDocsBatch+  :: HscEnv+  -> Module  -- ^ a moudle where the names are in scope+  -> [Name]+  -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)]+getDocsBatch hsc_env _mod _names = do+    ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->+        case nameModule_maybe name of+            Nothing -> return (Left $ NameHasNoModule name)+            Just mod -> do+             ModIface { mi_doc_hdr = mb_doc_hdr+                      , mi_decl_docs = DeclDocMap dmap+                      , mi_arg_docs = ArgDocMap amap+                      } <- loadModuleInterface "getModuleInterface" mod+             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap+               then pure (Left (NoDocsInIface mod $ compiled name))+               else pure (Right ( Map.lookup name dmap+                                , Map.findWithDefault Map.empty name amap))+    case res of+        Just x -> return $ map (first prettyPrint) x+        Nothing -> throwErrors errs+  where+    throwErrors = liftIO . throwIO . mkSrcErr+    compiled n =+      -- TODO: Find a more direct indicator.+      case nameSrcLoc n of+        RealSrcLoc {} -> False+        UnhelpfulLoc {} -> True++fakeSpan :: RealSrcSpan+fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<ghcide>") 1 1++-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.+--   The interactive paths create problems in ghc-lib builds+--- and leads to fun errors like "Cannot continue after interface file error".+lookupName :: HscEnv+           -> Module -- ^ A module where the Names are in scope+           -> Name+           -> IO (Maybe TyThing)+lookupName hsc_env mod name = do+    (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do+        tcthing <- tcLookup name+        case tcthing of+            AGlobal thing    -> return thing+            ATcId{tct_id=id} -> return (AnId id)+            _ -> panic "tcRnLookupName'"+    return res
src/Development/IDE/Core/Debouncer.hs view
@@ -1,57 +1,57 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Development.IDE.Core.Debouncer
-    ( Debouncer
-    , registerEvent
-    , newAsyncDebouncer
-    , noopDebouncer
-    ) where
-
-import Control.Concurrent.Extra
-import Control.Concurrent.Async
-import Control.Exception
-import Control.Monad.Extra
-import Data.Hashable
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as Map
-import System.Time.Extra
-
--- | A debouncer can be used to avoid triggering many events
--- (e.g. diagnostics) for the same key (e.g. the same file)
--- within a short timeframe. This is accomplished
--- by delaying each event for a given time. If another event
--- is registered for the same key within that timeframe,
--- only the new event will fire.
---
--- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable
--- debouncing in the DAML CLI compiler.
-newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }
-
--- | Debouncer used in the IDE that delays events as expected.
-newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
-newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
-
--- | Register an event that will fire after the given delay if no other event
--- for the same key gets registered until then.
---
--- If there is a pending event for the same key, the pending event will be killed.
--- Events are run unmasked so it is up to the user of `registerEvent`
--- to mask if required.
-asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
-asyncRegisterEvent d 0 k fire = do
-    modifyVar_ d $ \m -> mask_ $ do
-        whenJust (Map.lookup k m) cancel
-        pure $ Map.delete k m
-    fire
-asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
-    whenJust (Map.lookup k m) cancel
-    a <- asyncWithUnmask $ \unmask -> unmask $ do
-        sleep delay
-        fire
-        modifyVar_ d (pure . Map.delete k)
-    pure $ Map.insert k a m
-
--- | Debouncer used in the DAML CLI compiler that emits events immediately.
-noopDebouncer :: Debouncer k
-noopDebouncer = Debouncer $ \_ _ a -> a
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.Core.Debouncer+    ( Debouncer+    , registerEvent+    , newAsyncDebouncer+    , noopDebouncer+    ) where++import Control.Concurrent.Extra+import Control.Concurrent.Async+import Control.Exception+import Control.Monad.Extra+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import System.Time.Extra++-- | A debouncer can be used to avoid triggering many events+-- (e.g. diagnostics) for the same key (e.g. the same file)+-- within a short timeframe. This is accomplished+-- by delaying each event for a given time. If another event+-- is registered for the same key within that timeframe,+-- only the new event will fire.+--+-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable+-- debouncing in the DAML CLI compiler.+newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }++-- | Debouncer used in the IDE that delays events as expected.+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty++-- | Register an event that will fire after the given delay if no other event+-- for the same key gets registered until then.+--+-- If there is a pending event for the same key, the pending event will be killed.+-- Events are run unmasked so it is up to the user of `registerEvent`+-- to mask if required.+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()+asyncRegisterEvent d 0 k fire = do+    modifyVar_ d $ \m -> mask_ $ do+        whenJust (Map.lookup k m) cancel+        pure $ Map.delete k m+    fire+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do+    whenJust (Map.lookup k m) cancel+    a <- asyncWithUnmask $ \unmask -> unmask $ do+        sleep delay+        fire+        modifyVar_ d (pure . Map.delete k)+    pure $ Map.insert k a m++-- | Debouncer used in the DAML CLI compiler that emits events immediately.+noopDebouncer :: Debouncer k+noopDebouncer = Debouncer $ \_ _ a -> a
src/Development/IDE/Core/FileExists.hs view
@@ -1,229 +1,229 @@-{-# LANGUAGE OverloadedLists      #-}
-{-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Development.IDE.Core.FileExists
-  ( fileExistsRules
-  , modifyFileExists
-  , getFileExists
-  , watchedGlobs
-  )
-where
-
-import           Control.Concurrent.Extra
-import           Control.Exception
-import           Control.Monad.Extra
-import           Data.Binary
-import qualified Data.ByteString               as BS
-import           Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import           Data.Maybe
-import           Development.IDE.Core.FileStore
-import           Development.IDE.Core.IdeConfiguration
-import           Development.IDE.Core.Shake
-import           Development.IDE.Types.Location
-import           Development.IDE.Types.Options
-import           Development.Shake
-import           Development.Shake.Classes
-import           GHC.Generics
-import           Language.Haskell.LSP.Types.Capabilities
-import qualified System.Directory as Dir
-import qualified System.FilePath.Glob as Glob
-
-{- Note [File existence cache and LSP file watchers]
-Some LSP servers provide the ability to register file watches with the client, which will then notify
-us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky
-problem
-
-Here we use this to maintain a quick lookup cache of file existence. How this works is:
-- On startup, if the client supports it we ask it to watch some files (see below).
-- When those files are created or deleted (we can also see change events, but we don't
-care since we're only caching existence here) we get a notification from the client.
-- The notification handler calls 'modifyFileExists' to update our cache.
-
-This means that the cache will only ever work for the files we have set up a watcher for.
-So we pick the set that we mostly care about and which are likely to change existence
-most often: the source files of the project (as determined by the source extensions
-we're configured to care about).
-
-For all other files we fall back to the slow path.
-
-There are a few failure modes to think about:
-
-1. The client doesn't send us the notifications we asked for.
-
-There's not much we can do in this case: the whole point is to rely on the client so
-we don't do the checking ourselves. If the client lets us down, we will just be wrong.
-
-2. Races between registering watchers, getting notifications, and file changes.
-
-If a file changes status between us asking for notifications and the client actually
-setting up the notifications, we might not get told about it. But this is a relatively
-small race window around startup, so we just don't worry about it.
-
-3. Using the fast path for files that we aren't watching.
-
-In this case we will fall back to the slow path, but cache that result forever (since
-it won't get invalidated by a client notification). To prevent this we guard the
-fast path by a check that the path also matches our watching patterns.
--}
-
--- See Note [File existence cache and LSP file watchers]
--- | A map for tracking the file existence.
--- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and
--- if it's not in the map then we don't know.
-type FileExistsMap = (HashMap NormalizedFilePath Bool)
-
--- | A wrapper around a mutable 'FileExistsState'
-newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
-
-instance IsIdeGlobal FileExistsMapVar
-
--- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
-getFileExistsMapUntracked :: Action FileExistsMap
-getFileExistsMapUntracked = do
-  FileExistsMapVar v <- getIdeGlobalAction
-  liftIO $ readVar v
-
--- | Modify the global store of file exists.
-modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
-modifyFileExists state changes = do
-  FileExistsMapVar var <- getIdeGlobalState state
-  changesMap           <- evaluate $ HashMap.fromList changes
-  -- Masked to ensure that the previous values are flushed together with the map update
-  mask $ \_ -> do
-    -- update the map
-    modifyVar_ var $ evaluate . HashMap.union changesMap
-    -- See Note [Invalidating file existence results]
-    -- flush previous values
-    mapM_ (deleteValue state GetFileExists . fst) changes
-
--------------------------------------------------------------------------------------
-
-type instance RuleResult GetFileExists = Bool
-
-data GetFileExists = GetFileExists
-    deriving (Eq, Show, Typeable, Generic)
-
-instance NFData   GetFileExists
-instance Hashable GetFileExists
-instance Binary   GetFileExists
-
--- | Returns True if the file exists
---   Note that a file is not considered to exist unless it is saved to disk.
---   In particular, VFS existence is not enough.
---   Consider the following example:
---     1. The file @A.hs@ containing the line @import B@ is added to the files of interest
---        Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing
---     2. The editor creates a new buffer @B.hs@
---        Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up
---        Most editors, e.g. VSCode, only send the event when the file is saved to disk.
-getFileExists :: NormalizedFilePath -> Action Bool
-getFileExists fp = use_ GetFileExists fp
-
-{- Note [Which files should we watch?]
-The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob
-patterns.
-
-We used to have a quite precise system, where we would register a watcher for a single file path only (and always)
-when we actually looked to see if it existed. The downside of this is that it sends a *lot* of notifications
-to the client (thousands on a large project), and this could lock up some clients like emacs
-(https://github.com/emacs-lsp/lsp-mode/issues/2165).
-
-Now we take the opposite approach: we register a single, quite general watcher that looks for all files
-with a predefined set of extensions. The consequences are:
-- The client will have to watch more files. This is usually not too bad, since the pattern is a single glob,
-and the clients typically call out to an optimized implementation of file watching that understands globs.
-- The client will send us a lot more notifications. This isn't too bad in practice, since although
-we're watching a lot of files in principle, they don't get created or destroyed that often.
-- We won't ever hit the fast lookup path for files which aren't in our watch pattern, since the only way
-files get into our map is when the client sends us a notification about them because we're watching them.
-This is fine so long as we're watching the files we check most often, i.e. source files.
--}
-
--- | The list of file globs that we ask the client to watch.
-watchedGlobs :: IdeOptions -> [String]
-watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]]
-
--- | Installs the 'getFileExists' rules.
---   Provides a fast implementation if client supports dynamic watched files.
---   Creates a global state as a side effect in that case.
-fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules ()
-fileExistsRules ClientCapabilities{_workspace} vfs = do
-  -- Create the global always, although it should only be used if we have fast rules.
-  -- But there's a chance someone will send unexpected notifications anyway,
-  -- e.g. https://github.com/haskell/ghcide/issues/599
-  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
-
-  extras <- getShakeExtrasRules
-  opts <- liftIO $ getIdeOptionsIO extras
-  let globs = watchedGlobs opts
-
-  case () of
-    _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
-      , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
-      , Just True <- _dynamicRegistration
-        -> fileExistsRulesFast globs vfs
-      | otherwise -> fileExistsRulesSlow vfs
-
--- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.
-fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()
-fileExistsRulesFast globs vfs =
-    let patterns = fmap Glob.compile globs
-        fpMatches fp = any (\p -> Glob.match p fp) patterns
-    in defineEarlyCutoff $ \GetFileExists file -> do
-        isWf <- isWorkspaceFile file
-        if isWf && fpMatches (fromNormalizedFilePath file)
-            then fileExistsFast vfs file
-            else fileExistsSlow vfs file
-
-{- Note [Invalidating file existence results]
-We have two mechanisms for getting file existence information:
-- The file existence cache
-- The VFS lookup
-
-Both of these affect the results of the 'GetFileExists' rule, so we need to make sure it
-is invalidated properly when things change.
-
-For the file existence cache, we manually flush the results of 'GetFileExists' when we
-modify it (i.e. when a notification comes from the client). This is faster than using
-'alwaysRerun' in the 'fileExistsFast', and we need it to be as fast as possible.
-
-For the VFS lookup, however, we won't get prompted to flush the result, so instead
-we use 'alwaysRerun'.
--}
-
-fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
-fileExistsFast vfs file = do
-    -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results]
-    mp <- getFileExistsMapUntracked
-
-    let mbFilesWatched = HashMap.lookup file mp
-    exist <- case mbFilesWatched of
-      Just exist -> pure exist
-      -- We don't know about it: use the slow route.
-      -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'.
-      Nothing -> liftIO $ getFileExistsVFS vfs file
-    pure (summarizeExists exist, ([], Just exist))
-
-summarizeExists :: Bool -> Maybe BS.ByteString
-summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
-
-fileExistsRulesSlow :: VFSHandle -> Rules ()
-fileExistsRulesSlow vfs =
-  defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file
-
-fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
-fileExistsSlow vfs file = do
-    -- See Note [Invalidating file existence results]
-    alwaysRerun
-    exist <- liftIO $ getFileExistsVFS vfs file
-    pure (summarizeExists exist, ([], Just exist))
-
-getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
-getFileExistsVFS vfs file = do
-    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
-    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
-    -- cached 'No' rather than an exception in the wrong place
-    handle (\(_ :: IOException) -> return False) $
-        (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
-        Dir.doesFileExist (fromNormalizedFilePath file)
+{-# LANGUAGE OverloadedLists      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Development.IDE.Core.FileExists+  ( fileExistsRules+  , modifyFileExists+  , getFileExists+  , watchedGlobs+  )+where++import           Control.Concurrent.Extra+import           Control.Exception+import           Control.Monad.Extra+import           Data.Binary+import qualified Data.ByteString               as BS+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.Maybe+import           Development.IDE.Core.FileStore+import           Development.IDE.Core.IdeConfiguration+import           Development.IDE.Core.Shake+import           Development.IDE.Types.Location+import           Development.IDE.Types.Options+import           Development.Shake+import           Development.Shake.Classes+import           GHC.Generics+import           Language.Haskell.LSP.Types.Capabilities+import qualified System.Directory as Dir+import qualified System.FilePath.Glob as Glob++{- Note [File existence cache and LSP file watchers]+Some LSP servers provide the ability to register file watches with the client, which will then notify+us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky+problem++Here we use this to maintain a quick lookup cache of file existence. How this works is:+- On startup, if the client supports it we ask it to watch some files (see below).+- When those files are created or deleted (we can also see change events, but we don't+care since we're only caching existence here) we get a notification from the client.+- The notification handler calls 'modifyFileExists' to update our cache.++This means that the cache will only ever work for the files we have set up a watcher for.+So we pick the set that we mostly care about and which are likely to change existence+most often: the source files of the project (as determined by the source extensions+we're configured to care about).++For all other files we fall back to the slow path.++There are a few failure modes to think about:++1. The client doesn't send us the notifications we asked for.++There's not much we can do in this case: the whole point is to rely on the client so+we don't do the checking ourselves. If the client lets us down, we will just be wrong.++2. Races between registering watchers, getting notifications, and file changes.++If a file changes status between us asking for notifications and the client actually+setting up the notifications, we might not get told about it. But this is a relatively+small race window around startup, so we just don't worry about it.++3. Using the fast path for files that we aren't watching.++In this case we will fall back to the slow path, but cache that result forever (since+it won't get invalidated by a client notification). To prevent this we guard the+fast path by a check that the path also matches our watching patterns.+-}++-- See Note [File existence cache and LSP file watchers]+-- | A map for tracking the file existence.+-- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and+-- if it's not in the map then we don't know.+type FileExistsMap = (HashMap NormalizedFilePath Bool)++-- | A wrapper around a mutable 'FileExistsState'+newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)++instance IsIdeGlobal FileExistsMapVar++-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency+getFileExistsMapUntracked :: Action FileExistsMap+getFileExistsMapUntracked = do+  FileExistsMapVar v <- getIdeGlobalAction+  liftIO $ readVar v++-- | Modify the global store of file exists.+modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()+modifyFileExists state changes = do+  FileExistsMapVar var <- getIdeGlobalState state+  changesMap           <- evaluate $ HashMap.fromList changes+  -- Masked to ensure that the previous values are flushed together with the map update+  mask $ \_ -> do+    -- update the map+    modifyVar_ var $ evaluate . HashMap.union changesMap+    -- See Note [Invalidating file existence results]+    -- flush previous values+    mapM_ (deleteValue state GetFileExists . fst) changes++-------------------------------------------------------------------------------------++type instance RuleResult GetFileExists = Bool++data GetFileExists = GetFileExists+    deriving (Eq, Show, Typeable, Generic)++instance NFData   GetFileExists+instance Hashable GetFileExists+instance Binary   GetFileExists++-- | Returns True if the file exists+--   Note that a file is not considered to exist unless it is saved to disk.+--   In particular, VFS existence is not enough.+--   Consider the following example:+--     1. The file @A.hs@ containing the line @import B@ is added to the files of interest+--        Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing+--     2. The editor creates a new buffer @B.hs@+--        Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up+--        Most editors, e.g. VSCode, only send the event when the file is saved to disk.+getFileExists :: NormalizedFilePath -> Action Bool+getFileExists fp = use_ GetFileExists fp++{- Note [Which files should we watch?]+The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob+patterns.++We used to have a quite precise system, where we would register a watcher for a single file path only (and always)+when we actually looked to see if it existed. The downside of this is that it sends a *lot* of notifications+to the client (thousands on a large project), and this could lock up some clients like emacs+(https://github.com/emacs-lsp/lsp-mode/issues/2165).++Now we take the opposite approach: we register a single, quite general watcher that looks for all files+with a predefined set of extensions. The consequences are:+- The client will have to watch more files. This is usually not too bad, since the pattern is a single glob,+and the clients typically call out to an optimized implementation of file watching that understands globs.+- The client will send us a lot more notifications. This isn't too bad in practice, since although+we're watching a lot of files in principle, they don't get created or destroyed that often.+- We won't ever hit the fast lookup path for files which aren't in our watch pattern, since the only way+files get into our map is when the client sends us a notification about them because we're watching them.+This is fine so long as we're watching the files we check most often, i.e. source files.+-}++-- | The list of file globs that we ask the client to watch.+watchedGlobs :: IdeOptions -> [String]+watchedGlobs opts = [ "**/*." ++ extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext, ext ++ "-boot"]]++-- | Installs the 'getFileExists' rules.+--   Provides a fast implementation if client supports dynamic watched files.+--   Creates a global state as a side effect in that case.+fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules ()+fileExistsRules ClientCapabilities{_workspace} vfs = do+  -- Create the global always, although it should only be used if we have fast rules.+  -- But there's a chance someone will send unexpected notifications anyway,+  -- e.g. https://github.com/haskell/ghcide/issues/599+  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])++  extras <- getShakeExtrasRules+  opts <- liftIO $ getIdeOptionsIO extras+  let globs = watchedGlobs opts++  case () of+    _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+      , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+      , Just True <- _dynamicRegistration+        -> fileExistsRulesFast globs vfs+      | otherwise -> fileExistsRulesSlow vfs++-- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked.+fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()+fileExistsRulesFast globs vfs =+    let patterns = fmap Glob.compile globs+        fpMatches fp = any (\p -> Glob.match p fp) patterns+    in defineEarlyCutoff $ \GetFileExists file -> do+        isWf <- isWorkspaceFile file+        if isWf && fpMatches (fromNormalizedFilePath file)+            then fileExistsFast vfs file+            else fileExistsSlow vfs file++{- Note [Invalidating file existence results]+We have two mechanisms for getting file existence information:+- The file existence cache+- The VFS lookup++Both of these affect the results of the 'GetFileExists' rule, so we need to make sure it+is invalidated properly when things change.++For the file existence cache, we manually flush the results of 'GetFileExists' when we+modify it (i.e. when a notification comes from the client). This is faster than using+'alwaysRerun' in the 'fileExistsFast', and we need it to be as fast as possible.++For the VFS lookup, however, we won't get prompted to flush the result, so instead+we use 'alwaysRerun'.+-}++fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))+fileExistsFast vfs file = do+    -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results]+    mp <- getFileExistsMapUntracked++    let mbFilesWatched = HashMap.lookup file mp+    exist <- case mbFilesWatched of+      Just exist -> pure exist+      -- We don't know about it: use the slow route.+      -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'.+      Nothing -> liftIO $ getFileExistsVFS vfs file+    pure (summarizeExists exist, ([], Just exist))++summarizeExists :: Bool -> Maybe BS.ByteString+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty++fileExistsRulesSlow :: VFSHandle -> Rules ()+fileExistsRulesSlow vfs =+  defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file++fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))+fileExistsSlow vfs file = do+    -- See Note [Invalidating file existence results]+    alwaysRerun+    exist <- liftIO $ getFileExistsVFS vfs file+    pure (summarizeExists exist, ([], Just exist))++getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool+getFileExistsVFS vfs file = do+    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute+    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly+    -- cached 'No' rather than an exception in the wrong place+    handle (\(_ :: IOException) -> return False) $+        (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^+        Dir.doesFileExist (fromNormalizedFilePath file)
src/Development/IDE/Core/FileStore.hs view
@@ -1,248 +1,248 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Development.IDE.Core.FileStore(
-    getFileContents,
-    getVirtualFile,
-    setFileModified,
-    setSomethingModified,
-    fileStoreRules,
-    modificationTime,
-    typecheckParents,
-    VFSHandle,
-    makeVFSHandle,
-    makeLSPVFSHandle,
-    isFileOfInterestRule
-    ) where
-
-import Development.IDE.GHC.Orphans()
-import           Development.IDE.Core.Shake
-import Control.Concurrent.Extra
-import qualified Data.Map.Strict as Map
-import qualified Data.HashMap.Strict as HM
-import Data.Maybe
-import qualified Data.Text as T
-import           Control.Monad.Extra
-import           Development.Shake
-import           Development.Shake.Classes
-import           Control.Exception
-import Data.Either.Extra
-import Data.Int (Int64)
-import Data.Time
-import System.IO.Error
-import qualified Data.ByteString.Char8 as BS
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Location
-import Development.IDE.Core.OfInterest (getFilesOfInterest)
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Types.Options
-import qualified Data.Rope.UTF16 as Rope
-import Development.IDE.Import.DependencyInformation
-import Ide.Plugin.Config (CheckParents(..))
-
-#ifdef mingw32_HOST_OS
-import qualified System.Directory as Dir
-#else
-import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime))
-import Foreign.Ptr
-import Foreign.C.String
-import Foreign.C.Types
-import Foreign.Marshal (alloca)
-import Foreign.Storable
-import qualified System.Posix.Error as Posix
-#endif
-
-import qualified Development.IDE.Types.Logger as L
-
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.VFS
-
--- | haskell-lsp manages the VFS internally and automatically so we cannot use
--- the builtin VFS without spawning up an LSP server. To be able to test things
--- like `setBufferModified` we abstract over the VFS implementation.
-data VFSHandle = VFSHandle
-    { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
-        -- ^ get the contents of a virtual file
-    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
-        -- ^ set a specific file to a value. If Nothing then we are ignoring these
-        --   signals anyway so can just say something was modified
-    }
-
-instance IsIdeGlobal VFSHandle
-
-makeVFSHandle :: IO VFSHandle
-makeVFSHandle = do
-    vfsVar <- newVar (1, Map.empty)
-    pure VFSHandle
-        { getVirtualFile = \uri -> do
-              (_nextVersion, vfs) <- readVar vfsVar
-              pure $ Map.lookup uri vfs
-        , setVirtualFileContents = Just $ \uri content ->
-              modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
-                  case content of
-                    Nothing -> Map.delete uri vfs
-                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
-                    Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
-        }
-
-makeLSPVFSHandle :: LspFuncs c -> VFSHandle
-makeLSPVFSHandle lspFuncs = VFSHandle
-    { getVirtualFile = getVirtualFileFunc lspFuncs
-    , setVirtualFileContents = Nothing
-   }
-
-
-isFileOfInterestRule :: Rules ()
-isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
-    filesOfInterest <- getFilesOfInterest
-    let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest
-    return (Just $ BS.pack $ show $ hash res, ([], Just res))
-
-getModificationTimeRule :: VFSHandle -> Rules ()
-getModificationTimeRule vfs =
-    defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do
-        let file' = fromNormalizedFilePath file
-        let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
-        alwaysRerun
-        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
-        case mbVirtual of
-            Just (virtualFileVersion -> ver) ->
-                pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
-            Nothing -> liftIO $ fmap wrap (getModTime file')
-              `catch` \(e :: IOException) -> do
-                let err | isDoesNotExistError e = "File does not exist: " ++ file'
-                        | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
-                    diag = ideErrorText file (T.pack err)
-                if isDoesNotExistError e && not missingFileDiags
-                    then return (Nothing, ([], Nothing))
-                    else return (Nothing, ([diag], Nothing))
-
--- Dir.getModificationTime is surprisingly slow since it performs
--- a ton of conversions. Since we do not actually care about
--- the format of the time, we can get away with something cheaper.
--- For now, we only try to do this on Unix systems where it seems to get the
--- time spent checking file modifications (which happens on every change)
--- from > 0.5s to ~0.15s.
--- We might also want to try speeding this up on Windows at some point.
--- TODO leverage DidChangeWatchedFile lsp notifications on clients that
--- support them, as done for GetFileExists
-getModTime :: FilePath -> IO (Int64, Int64)
-getModTime f =
-#ifdef mingw32_HOST_OS
-    do time <- Dir.getModificationTime f
-       let !day = fromInteger $ toModifiedJulianDay $ utctDay time
-           !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
-       pure (day, dayTime)
-#else
-    withCString f $ \f' ->
-    alloca $ \secPtr ->
-    alloca $ \nsecPtr -> do
-        Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
-        CTime sec <- peek secPtr
-        CLong nsec <- peek nsecPtr
-        pure (sec, nsec)
-
--- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
--- as doing the FFI call ourselves :(.
-foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
-#endif
-
-modificationTime :: FileVersion -> Maybe UTCTime
-modificationTime VFSVersion{} = Nothing
-modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small
-
-internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime
-internalTimeToUTCTime large small =
-#ifdef mingw32_HOST_OS
-    UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small)
-#else
-    systemToUTCTime $ MkSystemTime large (fromIntegral small)
-#endif
-
-getFileContentsRule :: VFSHandle -> Rules ()
-getFileContentsRule vfs =
-    define $ \GetFileContents file -> do
-        -- need to depend on modification time to introduce a dependency with Cutoff
-        time <- use_ GetModificationTime file
-        res <- liftIO $ ideTryIOException file $ do
-            mbVirtual <- getVirtualFile vfs $ filePathToUri' file
-            pure $ Rope.toText . _text <$> mbVirtual
-        case res of
-            Left err -> return ([err], Nothing)
-            Right contents -> return ([], Just (time, contents))
-
-ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
-ideTryIOException fp act =
-  mapLeft
-      (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
-      <$> try act
-
--- | Returns the modification time and the contents.
---   For VFS paths, the modification time is the current time.
-getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)
-getFileContents f = do
-    (fv, txt) <- use_ GetFileContents f
-    modTime <- case modificationTime fv of
-      Just t -> pure t
-      Nothing -> do
-        foi <- use_ IsFileOfInterest f
-        liftIO $ case foi of
-          IsFOI Modified -> getCurrentTime
-          _ -> do
-            (large,small) <- getModTime $ fromNormalizedFilePath f
-            pure $ internalTimeToUTCTime large small
-    return (modTime, txt)
-
-fileStoreRules :: VFSHandle -> Rules ()
-fileStoreRules vfs = do
-    addIdeGlobal vfs
-    getModificationTimeRule vfs
-    getFileContentsRule vfs
-    isFileOfInterestRule
-
--- | Note that some buffer for a specific file has been modified but not
--- with what changes.
-setFileModified :: IdeState
-                -> Bool -- ^ Was the file saved?
-                -> NormalizedFilePath
-                -> IO ()
-setFileModified state saved nfp = do
-    ideOptions <- getIdeOptionsIO $ shakeExtras state
-    let checkParents = case optCheckParents ideOptions of
-          AlwaysCheck -> True
-          CheckOnSaveAndClose -> saved
-          _ -> False
-    VFSHandle{..} <- getIdeGlobalState state
-    when (isJust setVirtualFileContents) $
-        fail "setFileModified can't be called on this type of VFSHandle"
-    shakeRestart state []
-    when checkParents $
-      typecheckParents state nfp
-
-typecheckParents :: IdeState -> NormalizedFilePath -> IO ()
-typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents
-  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp)
-
-typecheckParentsAction :: NormalizedFilePath -> Action ()
-typecheckParentsAction nfp = do
-    revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph
-    logger <- logger <$> getShakeExtras
-    let log = L.logInfo logger . T.pack
-    case revs of
-      Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp
-      Just rs -> do
-        liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs)
-          `catch` \(e :: SomeException) -> log (show e)
-        () <$ uses GetModIface rs
-
--- | Note that some buffer somewhere has been modified, but don't say what.
---   Only valid if the virtual file system was initialised by LSP, as that
---   independently tracks which files are modified.
-setSomethingModified :: IdeState -> IO ()
-setSomethingModified state = do
-    VFSHandle{..} <- getIdeGlobalState state
-    when (isJust setVirtualFileContents) $
-        fail "setSomethingModified can't be called on this type of VFSHandle"
-    void $ shakeRestart state []
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module Development.IDE.Core.FileStore(+    getFileContents,+    getVirtualFile,+    setFileModified,+    setSomethingModified,+    fileStoreRules,+    modificationTime,+    typecheckParents,+    VFSHandle,+    makeVFSHandle,+    makeLSPVFSHandle,+    isFileOfInterestRule+    ) where++import Development.IDE.GHC.Orphans()+import           Development.IDE.Core.Shake+import Control.Concurrent.Extra+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import qualified Data.Text as T+import           Control.Monad.Extra+import           Development.Shake+import           Development.Shake.Classes+import           Control.Exception+import Data.Either.Extra+import Data.Int (Int64)+import Data.Time+import System.IO.Error+import qualified Data.ByteString.Char8 as BS+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.IDE.Core.OfInterest (getFilesOfInterest)+import Development.IDE.Core.RuleTypes+import Development.IDE.Types.Options+import qualified Data.Rope.UTF16 as Rope+import Development.IDE.Import.DependencyInformation+import Ide.Plugin.Config (CheckParents(..))++#ifdef mingw32_HOST_OS+import qualified System.Directory as Dir+#else+import Data.Time.Clock.System (systemToUTCTime, SystemTime(MkSystemTime))+import Foreign.Ptr+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal (alloca)+import Foreign.Storable+import qualified System.Posix.Error as Posix+#endif++import qualified Development.IDE.Types.Logger as L++import Language.Haskell.LSP.Core+import Language.Haskell.LSP.VFS++-- | haskell-lsp manages the VFS internally and automatically so we cannot use+-- the builtin VFS without spawning up an LSP server. To be able to test things+-- like `setBufferModified` we abstract over the VFS implementation.+data VFSHandle = VFSHandle+    { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)+        -- ^ get the contents of a virtual file+    , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())+        -- ^ set a specific file to a value. If Nothing then we are ignoring these+        --   signals anyway so can just say something was modified+    }++instance IsIdeGlobal VFSHandle++makeVFSHandle :: IO VFSHandle+makeVFSHandle = do+    vfsVar <- newVar (1, Map.empty)+    pure VFSHandle+        { getVirtualFile = \uri -> do+              (_nextVersion, vfs) <- readVar vfsVar+              pure $ Map.lookup uri vfs+        , setVirtualFileContents = Just $ \uri content ->+              modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $+                  case content of+                    Nothing -> Map.delete uri vfs+                    -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.+                    Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs+        }++makeLSPVFSHandle :: LspFuncs c -> VFSHandle+makeLSPVFSHandle lspFuncs = VFSHandle+    { getVirtualFile = getVirtualFileFunc lspFuncs+    , setVirtualFileContents = Nothing+   }+++isFileOfInterestRule :: Rules ()+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do+    filesOfInterest <- getFilesOfInterest+    let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest+    return (Just $ BS.pack $ show $ hash res, ([], Just res))++getModificationTimeRule :: VFSHandle -> Rules ()+getModificationTimeRule vfs =+    defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do+        let file' = fromNormalizedFilePath file+        let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))+        alwaysRerun+        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file+        case mbVirtual of+            Just (virtualFileVersion -> ver) ->+                pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))+            Nothing -> liftIO $ fmap wrap (getModTime file')+              `catch` \(e :: IOException) -> do+                let err | isDoesNotExistError e = "File does not exist: " ++ file'+                        | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e+                    diag = ideErrorText file (T.pack err)+                if isDoesNotExistError e && not missingFileDiags+                    then return (Nothing, ([], Nothing))+                    else return (Nothing, ([diag], Nothing))++-- Dir.getModificationTime is surprisingly slow since it performs+-- a ton of conversions. Since we do not actually care about+-- the format of the time, we can get away with something cheaper.+-- For now, we only try to do this on Unix systems where it seems to get the+-- time spent checking file modifications (which happens on every change)+-- from > 0.5s to ~0.15s.+-- We might also want to try speeding this up on Windows at some point.+-- TODO leverage DidChangeWatchedFile lsp notifications on clients that+-- support them, as done for GetFileExists+getModTime :: FilePath -> IO (Int64, Int64)+getModTime f =+#ifdef mingw32_HOST_OS+    do time <- Dir.getModificationTime f+       let !day = fromInteger $ toModifiedJulianDay $ utctDay time+           !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time+       pure (day, dayTime)+#else+    withCString f $ \f' ->+    alloca $ \secPtr ->+    alloca $ \nsecPtr -> do+        Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr+        CTime sec <- peek secPtr+        CLong nsec <- peek nsecPtr+        pure (sec, nsec)++-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow+-- as doing the FFI call ourselves :(.+foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int+#endif++modificationTime :: FileVersion -> Maybe UTCTime+modificationTime VFSVersion{} = Nothing+modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small++internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime+internalTimeToUTCTime large small =+#ifdef mingw32_HOST_OS+    UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small)+#else+    systemToUTCTime $ MkSystemTime large (fromIntegral small)+#endif++getFileContentsRule :: VFSHandle -> Rules ()+getFileContentsRule vfs =+    define $ \GetFileContents file -> do+        -- need to depend on modification time to introduce a dependency with Cutoff+        time <- use_ GetModificationTime file+        res <- liftIO $ ideTryIOException file $ do+            mbVirtual <- getVirtualFile vfs $ filePathToUri' file+            pure $ Rope.toText . _text <$> mbVirtual+        case res of+            Left err -> return ([err], Nothing)+            Right contents -> return ([], Just (time, contents))++ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)+ideTryIOException fp act =+  mapLeft+      (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)+      <$> try act++-- | Returns the modification time and the contents.+--   For VFS paths, the modification time is the current time.+getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text)+getFileContents f = do+    (fv, txt) <- use_ GetFileContents f+    modTime <- case modificationTime fv of+      Just t -> pure t+      Nothing -> do+        foi <- use_ IsFileOfInterest f+        liftIO $ case foi of+          IsFOI Modified -> getCurrentTime+          _ -> do+            (large,small) <- getModTime $ fromNormalizedFilePath f+            pure $ internalTimeToUTCTime large small+    return (modTime, txt)++fileStoreRules :: VFSHandle -> Rules ()+fileStoreRules vfs = do+    addIdeGlobal vfs+    getModificationTimeRule vfs+    getFileContentsRule vfs+    isFileOfInterestRule++-- | Note that some buffer for a specific file has been modified but not+-- with what changes.+setFileModified :: IdeState+                -> Bool -- ^ Was the file saved?+                -> NormalizedFilePath+                -> IO ()+setFileModified state saved nfp = do+    ideOptions <- getIdeOptionsIO $ shakeExtras state+    let checkParents = case optCheckParents ideOptions of+          AlwaysCheck -> True+          CheckOnSaveAndClose -> saved+          _ -> False+    VFSHandle{..} <- getIdeGlobalState state+    when (isJust setVirtualFileContents) $+        fail "setFileModified can't be called on this type of VFSHandle"+    shakeRestart state []+    when checkParents $+      typecheckParents state nfp++typecheckParents :: IdeState -> NormalizedFilePath -> IO ()+typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents+  where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp)++typecheckParentsAction :: NormalizedFilePath -> Action ()+typecheckParentsAction nfp = do+    revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph+    logger <- logger <$> getShakeExtras+    let log = L.logInfo logger . T.pack+    case revs of+      Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp+      Just rs -> do+        liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs)+          `catch` \(e :: SomeException) -> log (show e)+        () <$ uses GetModIface rs++-- | Note that some buffer somewhere has been modified, but don't say what.+--   Only valid if the virtual file system was initialised by LSP, as that+--   independently tracks which files are modified.+setSomethingModified :: IdeState -> IO ()+setSomethingModified state = do+    VFSHandle{..} <- getIdeGlobalState state+    when (isJust setVirtualFileContents) $+        fail "setSomethingModified can't be called on this type of VFSHandle"+    void $ shakeRestart state []
src/Development/IDE/Core/IdeConfiguration.hs view
@@ -1,91 +1,91 @@-{-# LANGUAGE DuplicateRecordFields #-}
-module Development.IDE.Core.IdeConfiguration
-  ( IdeConfiguration(..)
-  , registerIdeConfiguration
-  , getIdeConfiguration
-  , parseConfiguration
-  , parseWorkspaceFolder
-  , isWorkspaceFile
-  , modifyWorkspaceFolders
-  , modifyClientSettings
-  , getClientSettings
-  )
-where
-
-import           Control.Concurrent.Extra
-import           Control.Monad
-import           Data.Hashable                  (Hashed, hashed, unhashed)
-import           Data.HashSet                   (HashSet, singleton)
-import           Data.Text                      (Text, isPrefixOf)
-import           Data.Aeson.Types               (Value)
-import           Development.IDE.Core.Shake
-import           Development.IDE.Types.Location
-import           Development.Shake
-import           Language.Haskell.LSP.Types
-import           System.FilePath (isRelative)
-
--- | Lsp client relevant configuration details
-data IdeConfiguration = IdeConfiguration
-  { workspaceFolders :: HashSet NormalizedUri
-  , clientSettings :: Hashed (Maybe Value)
-  }
-  deriving (Show)
-
-newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}
-
-instance IsIdeGlobal IdeConfigurationVar
-
-registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
-registerIdeConfiguration extras =
-  addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar
-
-getIdeConfiguration :: Action IdeConfiguration
-getIdeConfiguration =
-  getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef
-
-parseConfiguration :: InitializeParams -> IdeConfiguration
-parseConfiguration InitializeParams {..} =
-  IdeConfiguration {..}
- where
-  workspaceFolders =
-    foldMap (singleton . toNormalizedUri) _rootUri
-      <> (foldMap . foldMap)
-           (singleton . parseWorkspaceFolder)
-           _workspaceFolders
-  clientSettings = hashed _initializationOptions
-
-parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
-parseWorkspaceFolder =
-  toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
-
-modifyWorkspaceFolders
-  :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
-modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f'
-  where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts
-
-modifyClientSettings
-  :: IdeState -> (Maybe Value -> Maybe Value) -> IO ()
-modifyClientSettings ide f = modifyIdeConfiguration ide f'
-  where f' (IdeConfiguration ws clientSettings) =
-            IdeConfiguration ws (hashed . f . unhashed $ clientSettings)
-
-modifyIdeConfiguration
-  :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
-modifyIdeConfiguration ide f = do
-  IdeConfigurationVar var <- getIdeGlobalState ide
-  modifyVar_ var (pure . f)
-
-isWorkspaceFile :: NormalizedFilePath -> Action Bool
-isWorkspaceFile file =
-  if isRelative (fromNormalizedFilePath file)
-    then return True
-    else do
-      IdeConfiguration {..} <- getIdeConfiguration
-      let toText = getUri . fromNormalizedUri
-      return $
-        any
-          (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
-          workspaceFolders
-
-getClientSettings :: Action (Maybe Value)
-getClientSettings = unhashed . clientSettings <$> getIdeConfiguration
+{-# LANGUAGE DuplicateRecordFields #-}+module Development.IDE.Core.IdeConfiguration+  ( IdeConfiguration(..)+  , registerIdeConfiguration+  , getIdeConfiguration+  , parseConfiguration+  , parseWorkspaceFolder+  , isWorkspaceFile+  , modifyWorkspaceFolders+  , modifyClientSettings+  , getClientSettings+  )+where++import           Control.Concurrent.Extra+import           Control.Monad+import           Data.Hashable                  (Hashed, hashed, unhashed)+import           Data.HashSet                   (HashSet, singleton)+import           Data.Text                      (Text, isPrefixOf)+import           Data.Aeson.Types               (Value)+import           Development.IDE.Core.Shake+import           Development.IDE.Types.Location+import           Development.Shake+import           Language.Haskell.LSP.Types+import           System.FilePath (isRelative)++-- | Lsp client relevant configuration details+data IdeConfiguration = IdeConfiguration+  { workspaceFolders :: HashSet NormalizedUri+  , clientSettings :: Hashed (Maybe Value)+  }+  deriving (Show)++newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}++instance IsIdeGlobal IdeConfigurationVar++registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()+registerIdeConfiguration extras =+  addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar++getIdeConfiguration :: Action IdeConfiguration+getIdeConfiguration =+  getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef++parseConfiguration :: InitializeParams -> IdeConfiguration+parseConfiguration InitializeParams {..} =+  IdeConfiguration {..}+ where+  workspaceFolders =+    foldMap (singleton . toNormalizedUri) _rootUri+      <> (foldMap . foldMap)+           (singleton . parseWorkspaceFolder)+           _workspaceFolders+  clientSettings = hashed _initializationOptions++parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri+parseWorkspaceFolder =+  toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)++modifyWorkspaceFolders+  :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()+modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f'+  where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts++modifyClientSettings+  :: IdeState -> (Maybe Value -> Maybe Value) -> IO ()+modifyClientSettings ide f = modifyIdeConfiguration ide f'+  where f' (IdeConfiguration ws clientSettings) =+            IdeConfiguration ws (hashed . f . unhashed $ clientSettings)++modifyIdeConfiguration+  :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()+modifyIdeConfiguration ide f = do+  IdeConfigurationVar var <- getIdeGlobalState ide+  modifyVar_ var (pure . f)++isWorkspaceFile :: NormalizedFilePath -> Action Bool+isWorkspaceFile file =+  if isRelative (fromNormalizedFilePath file)+    then return True+    else do+      IdeConfiguration {..} <- getIdeConfiguration+      let toText = getUri . fromNormalizedUri+      return $+        any+          (\root -> toText root `isPrefixOf` toText (filePathToUri' file))+          workspaceFolders++getClientSettings :: Action (Maybe Value)+getClientSettings = unhashed . clientSettings <$> getIdeConfiguration
src/Development/IDE/Core/OfInterest.hs view
@@ -1,120 +1,120 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances #-}
-
--- | Utilities and state for the files of interest - those which are currently
---   open in the editor. The useful function is 'getFilesOfInterest'.
-module Development.IDE.Core.OfInterest(
-    ofInterestRules,
-    getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
-    kick, FileOfInterestStatus(..)
-    ) where
-
-import Control.Concurrent.Extra
-import Data.Binary
-import Data.Hashable
-import Control.DeepSeq
-import GHC.Generics
-import Data.Typeable
-import qualified Data.ByteString.UTF8 as BS
-import Control.Exception
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Text as T
-import Data.Tuple.Extra
-import Development.Shake
-import Control.Monad (void)
-
-import Development.IDE.Types.Exports
-import Development.IDE.Types.Location
-import Development.IDE.Types.Logger
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Core.Shake
-import Data.Maybe (catMaybes)
-import Data.List.Extra (nubOrd)
-import Development.IDE.Import.DependencyInformation
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Class
-import Development.IDE.Types.Options
-
-newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
-instance IsIdeGlobal OfInterestVar
-
-type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus
-
-data GetFilesOfInterest = GetFilesOfInterest
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetFilesOfInterest
-instance NFData   GetFilesOfInterest
-instance Binary   GetFilesOfInterest
-
-
--- | The rule that initialises the files of interest state.
-ofInterestRules :: Rules ()
-ofInterestRules = do
-    addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)
-    defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
-        alwaysRerun
-        filesOfInterest <- getFilesOfInterestUntracked
-        pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
-
-
--- | Get the files that are open in the IDE.
-getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
-getFilesOfInterest = useNoFile_ GetFilesOfInterest
-
-
-
-------------------------------------------------------------
--- Exposed API
-
--- | Set the files-of-interest - not usually necessary or advisable.
---   The LSP client will keep this information up to date.
-setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
-setFilesOfInterest state files = modifyFilesOfInterest state (const files)
-
-getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)
-getFilesOfInterestUntracked = do
-    OfInterestVar var <- getIdeGlobalAction
-    liftIO $ readVar var
-
--- | Modify the files-of-interest - not usually necessary or advisable.
---   The LSP client will keep this information up to date.
-modifyFilesOfInterest
-  :: IdeState
-  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)
-  -> IO ()
-modifyFilesOfInterest state f = do
-    OfInterestVar var <- getIdeGlobalState state
-    files <- modifyVar var $ pure . dupe . f
-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)
-
--- | Typecheck all the files of interest.
---   Could be improved
-kick :: Action ()
-kick = do
-    files <- HashMap.keys <$> getFilesOfInterest
-    ShakeExtras{progressUpdate} <- getShakeExtras
-    liftIO $ progressUpdate KickStarted
-
-    -- Update the exports map for FOIs
-    (results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files)
-
-    -- Update the exports map for non FOIs
-    -- We can skip this if checkProject is True, assuming they never change under our feet.
-    IdeOptions{ optCheckProject = checkProject } <- getIdeOptions
-    ifaces <- if checkProject then return Nothing else runMaybeT $ do
-        deps <- MaybeT $ sequence <$> uses GetDependencies files
-        hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps)
-        return $ map hirModIface $ catMaybes hiResults
-
-    ShakeExtras{exportsMap} <- getShakeExtras
-    let mguts = catMaybes results
-        !exportsMap' = createExportsMapMg mguts
-        !exportsMap'' = maybe mempty createExportsMap ifaces
-    liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap'' <>) . (exportsMap' <>)
-
-    liftIO $ progressUpdate KickCompleted
-
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Utilities and state for the files of interest - those which are currently+--   open in the editor. The useful function is 'getFilesOfInterest'.+module Development.IDE.Core.OfInterest(+    ofInterestRules,+    getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,+    kick, FileOfInterestStatus(..)+    ) where++import Control.Concurrent.Extra+import Data.Binary+import Data.Hashable+import Control.DeepSeq+import GHC.Generics+import Data.Typeable+import qualified Data.ByteString.UTF8 as BS+import Control.Exception+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import Data.Tuple.Extra+import Development.Shake+import Control.Monad (void)++import Development.IDE.Types.Exports+import Development.IDE.Types.Location+import Development.IDE.Types.Logger+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Shake+import Data.Maybe (catMaybes)+import Data.List.Extra (nubOrd)+import Development.IDE.Import.DependencyInformation+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Development.IDE.Types.Options++newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))+instance IsIdeGlobal OfInterestVar++type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus++data GetFilesOfInterest = GetFilesOfInterest+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetFilesOfInterest+instance NFData   GetFilesOfInterest+instance Binary   GetFilesOfInterest+++-- | The rule that initialises the files of interest state.+ofInterestRules :: Rules ()+ofInterestRules = do+    addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)+    defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do+        alwaysRerun+        filesOfInterest <- getFilesOfInterestUntracked+        pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))+++-- | Get the files that are open in the IDE.+getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus)+getFilesOfInterest = useNoFile_ GetFilesOfInterest++++------------------------------------------------------------+-- Exposed API++-- | Set the files-of-interest - not usually necessary or advisable.+--   The LSP client will keep this information up to date.+setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()+setFilesOfInterest state files = modifyFilesOfInterest state (const files)++getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus)+getFilesOfInterestUntracked = do+    OfInterestVar var <- getIdeGlobalAction+    liftIO $ readVar var++-- | Modify the files-of-interest - not usually necessary or advisable.+--   The LSP client will keep this information up to date.+modifyFilesOfInterest+  :: IdeState+  -> (HashMap NormalizedFilePath FileOfInterestStatus -> HashMap NormalizedFilePath FileOfInterestStatus)+  -> IO ()+modifyFilesOfInterest state f = do+    OfInterestVar var <- getIdeGlobalState state+    files <- modifyVar var $ pure . dupe . f+    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashMap.toList files)++-- | Typecheck all the files of interest.+--   Could be improved+kick :: Action ()+kick = do+    files <- HashMap.keys <$> getFilesOfInterest+    ShakeExtras{progressUpdate} <- getShakeExtras+    liftIO $ progressUpdate KickStarted++    -- Update the exports map for FOIs+    (results, ()) <- par (uses GenerateCore files) (void $ uses GetHieAst files)++    -- Update the exports map for non FOIs+    -- We can skip this if checkProject is True, assuming they never change under our feet.+    IdeOptions{ optCheckProject = checkProject } <- getIdeOptions+    ifaces <- if checkProject then return Nothing else runMaybeT $ do+        deps <- MaybeT $ sequence <$> uses GetDependencies files+        hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps)+        return $ map hirModIface $ catMaybes hiResults++    ShakeExtras{exportsMap} <- getShakeExtras+    let mguts = catMaybes results+        !exportsMap' = createExportsMapMg mguts+        !exportsMap'' = maybe mempty createExportsMap ifaces+    liftIO $ modifyVar_ exportsMap $ evaluate . (exportsMap'' <>) . (exportsMap' <>)++    liftIO $ progressUpdate KickCompleted+
src/Development/IDE/Core/PositionMapping.hs view
@@ -1,160 +1,160 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-module Development.IDE.Core.PositionMapping
-  ( PositionMapping(..)
-  , PositionResult(..)
-  , lowerRange
-  , upperRange
-  , positionResultToMaybe
-  , fromCurrentPosition
-  , toCurrentPosition
-  , PositionDelta(..)
-  , addDelta
-  , mkDelta
-  , toCurrentRange
-  , fromCurrentRange
-  , applyChange
-  , zeroMapping
-  -- toCurrent and fromCurrent are mainly exposed for testing
-  , toCurrent
-  , fromCurrent
-  ) where
-
-import Control.Monad
-import qualified Data.Text as T
-import Language.Haskell.LSP.Types
-import Data.List
-
--- | Either an exact position, or the range of text that was substituted
-data PositionResult a
-  = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential
-  { unsafeLowerRange :: a
-  , unsafeUpperRange :: a }
-  | PositionExact !a
-  deriving (Eq,Ord,Show,Functor)
-
-lowerRange :: PositionResult a -> a
-lowerRange (PositionExact a) = a
-lowerRange (PositionRange lower _) = lower
-
-upperRange :: PositionResult a -> a
-upperRange (PositionExact a) = a
-upperRange (PositionRange _ upper) = upper
-
-positionResultToMaybe :: PositionResult a -> Maybe a
-positionResultToMaybe (PositionExact a) = Just a
-positionResultToMaybe _ = Nothing
-
-instance Applicative PositionResult where
-  pure = PositionExact
-  (PositionExact f) <*> a = fmap f a
-  (PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a)
-  (PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper)
-
-instance Monad PositionResult where
-  (PositionExact a) >>= f = f a
-  (PositionRange lower upper) >>= f = PositionRange lower' upper'
-    where
-      lower' = lowerRange $ f lower
-      upper' = upperRange $ f upper
-
--- The position delta is the difference between two versions
-data PositionDelta = PositionDelta
-  { toDelta :: !(Position -> PositionResult Position)
-  , fromDelta :: !(Position -> PositionResult Position)
-  }
-
-fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
-fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm
-
-toCurrentPosition :: PositionMapping -> Position -> Maybe Position
-toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm
-
--- A position mapping is the difference from the current version to
--- a specific version
-newtype PositionMapping = PositionMapping PositionDelta
-
-toCurrentRange :: PositionMapping -> Range -> Maybe Range
-toCurrentRange mapping (Range a b) =
-    Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
-
-fromCurrentRange :: PositionMapping -> Range -> Maybe Range
-fromCurrentRange mapping (Range a b) =
-    Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
-
-zeroMapping :: PositionMapping
-zeroMapping = PositionMapping idDelta
-
--- | Compose two position mappings. Composes in the same way as function
--- composition (ie the second argument is applyed to the position first).
-composeDelta :: PositionDelta
-                -> PositionDelta
-                -> PositionDelta
-composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =
-  PositionDelta (to1 <=< to2)
-                (from1 >=> from2)
-
-idDelta :: PositionDelta
-idDelta = PositionDelta pure pure
-
--- | Convert a set of changes into a delta from k  to k + 1
-mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
-mkDelta cs = foldl' applyChange idDelta cs
-
--- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n
-addDelta :: PositionDelta -> PositionMapping -> PositionMapping
-addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)
-
-applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
-applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta
-    { toDelta = toCurrent r t <=< toDelta
-    , fromDelta = fromDelta <=< fromCurrent r t
-    }
-applyChange posMapping _ = posMapping
-
-toCurrent :: Range -> T.Text -> Position -> PositionResult Position
-toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
-    | line < startLine || line == startLine && column < startColumn =
-      -- Position is before the change and thereby unchanged.
-      PositionExact $ Position line column
-    | line > endLine || line == endLine && column >= endColumn =
-      -- Position is after the change so increase line and column number
-      -- as necessary.
-      PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn
-    | otherwise = PositionRange start end
-    -- Position is in the region that was changed.
-    where
-        lineDiff = linesNew - linesOld
-        linesNew = T.count "\n" t
-        linesOld = endLine - startLine
-        newEndColumn
-          | linesNew == 0 = startColumn + T.length t
-          | otherwise = T.length $ T.takeWhileEnd (/= '\n') t
-        newColumn
-          | line == endLine = column + newEndColumn - endColumn
-          | otherwise = column
-        newLine = line + lineDiff
-
-fromCurrent :: Range -> T.Text -> Position -> PositionResult Position
-fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
-    | line < startLine || line == startLine && column < startColumn =
-      -- Position is before the change and thereby unchanged
-      PositionExact $ Position line column
-    | line > newEndLine || line == newEndLine && column >= newEndColumn =
-      -- Position is after the change so increase line and column number
-      -- as necessary.
-      PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn
-    | otherwise = PositionRange start end
-    -- Position is in the region that was changed.
-    where
-        lineDiff = linesNew - linesOld
-        linesNew = T.count "\n" t
-        linesOld = endLine - startLine
-        newEndLine = endLine + lineDiff
-        newEndColumn
-          | linesNew == 0 = startColumn + T.length t
-          | otherwise = T.length $ T.takeWhileEnd (/= '\n') t
-        newColumn
-          | line == newEndLine = column - (newEndColumn - endColumn)
-          | otherwise = column
-        newLine = line - lineDiff
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+module Development.IDE.Core.PositionMapping+  ( PositionMapping(..)+  , PositionResult(..)+  , lowerRange+  , upperRange+  , positionResultToMaybe+  , fromCurrentPosition+  , toCurrentPosition+  , PositionDelta(..)+  , addDelta+  , mkDelta+  , toCurrentRange+  , fromCurrentRange+  , applyChange+  , zeroMapping+  -- toCurrent and fromCurrent are mainly exposed for testing+  , toCurrent+  , fromCurrent+  ) where++import Control.Monad+import qualified Data.Text as T+import Language.Haskell.LSP.Types+import Data.List++-- | Either an exact position, or the range of text that was substituted+data PositionResult a+  = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential+  { unsafeLowerRange :: a+  , unsafeUpperRange :: a }+  | PositionExact !a+  deriving (Eq,Ord,Show,Functor)++lowerRange :: PositionResult a -> a+lowerRange (PositionExact a) = a+lowerRange (PositionRange lower _) = lower++upperRange :: PositionResult a -> a+upperRange (PositionExact a) = a+upperRange (PositionRange _ upper) = upper++positionResultToMaybe :: PositionResult a -> Maybe a+positionResultToMaybe (PositionExact a) = Just a+positionResultToMaybe _ = Nothing++instance Applicative PositionResult where+  pure = PositionExact+  (PositionExact f) <*> a = fmap f a+  (PositionRange f g) <*> (PositionExact a) = PositionRange (f a) (g a)+  (PositionRange f g) <*> (PositionRange lower upper) = PositionRange (f lower) (g upper)++instance Monad PositionResult where+  (PositionExact a) >>= f = f a+  (PositionRange lower upper) >>= f = PositionRange lower' upper'+    where+      lower' = lowerRange $ f lower+      upper' = upperRange $ f upper++-- The position delta is the difference between two versions+data PositionDelta = PositionDelta+  { toDelta :: !(Position -> PositionResult Position)+  , fromDelta :: !(Position -> PositionResult Position)+  }++fromCurrentPosition :: PositionMapping -> Position -> Maybe Position+fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm++toCurrentPosition :: PositionMapping -> Position -> Maybe Position+toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm++-- A position mapping is the difference from the current version to+-- a specific version+newtype PositionMapping = PositionMapping PositionDelta++toCurrentRange :: PositionMapping -> Range -> Maybe Range+toCurrentRange mapping (Range a b) =+    Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b++fromCurrentRange :: PositionMapping -> Range -> Maybe Range+fromCurrentRange mapping (Range a b) =+    Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b++zeroMapping :: PositionMapping+zeroMapping = PositionMapping idDelta++-- | Compose two position mappings. Composes in the same way as function+-- composition (ie the second argument is applyed to the position first).+composeDelta :: PositionDelta+                -> PositionDelta+                -> PositionDelta+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =+  PositionDelta (to1 <=< to2)+                (from1 >=> from2)++idDelta :: PositionDelta+idDelta = PositionDelta pure pure++-- | Convert a set of changes into a delta from k  to k + 1+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta+mkDelta cs = foldl' applyChange idDelta cs++-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n+addDelta :: PositionDelta -> PositionMapping -> PositionMapping+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)++applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta+    { toDelta = toCurrent r t <=< toDelta+    , fromDelta = fromDelta <=< fromCurrent r t+    }+applyChange posMapping _ = posMapping++toCurrent :: Range -> T.Text -> Position -> PositionResult Position+toCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)+    | line < startLine || line == startLine && column < startColumn =+      -- Position is before the change and thereby unchanged.+      PositionExact $ Position line column+    | line > endLine || line == endLine && column >= endColumn =+      -- Position is after the change so increase line and column number+      -- as necessary.+      PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn+    | otherwise = PositionRange start end+    -- Position is in the region that was changed.+    where+        lineDiff = linesNew - linesOld+        linesNew = T.count "\n" t+        linesOld = endLine - startLine+        newEndColumn+          | linesNew == 0 = startColumn + T.length t+          | otherwise = T.length $ T.takeWhileEnd (/= '\n') t+        newColumn+          | line == endLine = column + newEndColumn - endColumn+          | otherwise = column+        newLine = line + lineDiff++fromCurrent :: Range -> T.Text -> Position -> PositionResult Position+fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)+    | line < startLine || line == startLine && column < startColumn =+      -- Position is before the change and thereby unchanged+      PositionExact $ Position line column+    | line > newEndLine || line == newEndLine && column >= newEndColumn =+      -- Position is after the change so increase line and column number+      -- as necessary.+      PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn+    | otherwise = PositionRange start end+    -- Position is in the region that was changed.+    where+        lineDiff = linesNew - linesOld+        linesNew = T.count "\n" t+        linesOld = endLine - startLine+        newEndLine = endLine + lineDiff+        newEndColumn+          | linesNew == 0 = startColumn + T.length t+          | otherwise = T.length $ T.takeWhileEnd (/= '\n') t+        newColumn+          | line == newEndLine = column - (newEndColumn - endColumn)+          | otherwise = column+        newLine = line - lineDiff
src/Development/IDE/Core/Preprocessor.hs view
@@ -1,227 +1,227 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Development.IDE.Core.Preprocessor
-  ( preprocessor
-  ) where
-
-import Development.IDE.GHC.CPP
-import Development.IDE.GHC.Orphans()
-import Development.IDE.GHC.Compat
-import GhcMonad
-import StringBuffer as SB
-
-import Data.List.Extra
-import System.FilePath
-import System.IO.Extra
-import Data.Char
-import qualified HeaderInfo as Hdr
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Location
-import Development.IDE.GHC.Error
-import SysTools (Option (..), runUnlit, runPp)
-import Control.Monad.Trans.Except
-import qualified GHC.LanguageExtensions as LangExt
-import Data.Maybe
-import Control.Exception.Safe (catch, throw)
-import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Outputable (showSDoc)
-import Control.DeepSeq (NFData(rnf))
-import Control.Exception (evaluate)
-import HscTypes (HscEnv(hsc_dflags))
-
-
--- | Given a file and some contents, apply any necessary preprocessors,
---   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
-preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
-preprocessor env filename mbContents = do
-    -- Perform unlit
-    (isOnDisk, contents) <-
-        if isLiterate filename then do
-            let dflags = hsc_dflags env
-            newcontent <- liftIO $ runLhs dflags filename mbContents
-            return (False, newcontent)
-        else do
-            contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
-            let isOnDisk = isNothing mbContents
-            return (isOnDisk, contents)
-
-    -- Perform cpp
-    dflags  <- ExceptT $ parsePragmasIntoDynFlags env filename contents
-    (isOnDisk, contents, dflags) <-
-        if not $ xopt LangExt.Cpp dflags then
-            return (isOnDisk, contents, dflags)
-        else do
-            cppLogs <- liftIO $ newIORef []
-            contents <- ExceptT
-                        $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename
-                                       $ if isOnDisk then Nothing else Just contents))
-                            `catch`
-                            ( \(e :: GhcException) -> do
-                                logs <- readIORef cppLogs
-                                case diagsFromCPPLogs filename (reverse logs) of
-                                  [] -> throw e
-                                  diags -> return $ Left diags
-                            )
-            dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents
-            return (False, contents, dflags)
-
-    -- Perform preprocessor
-    if not $ gopt Opt_Pp dflags then
-        return (contents, dflags)
-    else do
-        contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
-        dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents
-        return (contents, dflags)
-  where
-    logAction :: IORef [CPPLog] -> LogAction
-    logAction cppLogs dflags _reason severity srcSpan _style msg = do
-      let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
-      modifyIORef cppLogs (log :)
-
-
-data CPPLog = CPPLog Severity SrcSpan Text
-  deriving (Show)
-
-
-data CPPDiag
-  = CPPDiag
-      { cdRange :: Range,
-        cdSeverity :: Maybe DiagnosticSeverity,
-        cdMessage :: [Text]
-      }
-  deriving (Show)
-
-
-diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
-diagsFromCPPLogs filename logs =
-  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
-    go [] logs
-  where
-    -- On errors, CPP calls logAction with a real span for the initial log and
-    -- then additional informational logs with `UnhelpfulSpan`. Collect those
-    -- informational log messages and attaches them to the initial log message.
-    go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
-    go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc
-    go acc (CPPLog sev (RealSrcSpan span) msg : logs) =
-      let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]
-       in go (diag : acc) logs
-    go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =
-      go (diag {cdMessage = msg : cdMessage diag} : diags) logs
-    go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs
-    cppDiagToDiagnostic :: CPPDiag -> Diagnostic
-    cppDiagToDiagnostic d =
-      Diagnostic
-        { _range = cdRange d,
-          _severity = cdSeverity d,
-          _code = Nothing,
-          _source = Just "CPP",
-          _message = T.unlines $ cdMessage d,
-          _relatedInformation = Nothing,
-          _tags = Nothing
-        }
-
-
-isLiterate :: FilePath -> Bool
-isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
-
-
--- | This reads the pragma information directly from the provided buffer.
-parsePragmasIntoDynFlags
-    :: HscEnv
-    -> FilePath
-    -> SB.StringBuffer
-    -> IO (Either [FileDiagnostic] DynFlags)
-parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do
-    let opts = Hdr.getOptions dflags0 contents fp
-
-    -- Force bits that might keep the dflags and stringBuffer alive unnecessarily
-    evaluate $ rnf opts
-
-    (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
-    dflags' <- initializePlugins env dflags
-    return $ disableWarningsAsErrors dflags'
-  where dflags0 = hsc_dflags env
-
--- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
-runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
-runLhs dflags filename contents = withTempDir $ \dir -> do
-    let fout = dir </> takeFileName filename <.> "unlit"
-    filesrc <- case contents of
-        Nothing   -> return filename
-        Just cnts -> do
-            let fsrc = dir </> takeFileName filename <.> "literate"
-            withBinaryFile fsrc WriteMode $ \h ->
-                hPutStringBuffer h cnts
-            return fsrc
-    unlit filesrc fout
-    SB.hGetStringBuffer fout
-  where
-    unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
-    args filein fileout = [
-                      SysTools.Option     "-h"
-                    , SysTools.Option     (escape filename) -- name this file
-                    , SysTools.FileOption "" filein       -- input file
-                    , SysTools.FileOption "" fileout ]    -- output file
-    -- taken from ghc's DriverPipeline.hs
-    escape ('\\':cs) = '\\':'\\': escape cs
-    escape ('\"':cs) = '\\':'\"': escape cs
-    escape ('\'':cs) = '\\':'\'': escape cs
-    escape (c:cs)    = c : escape cs
-    escape []        = []
-
--- | Run CPP on a file
-runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
-runCpp dflags filename contents = withTempDir $ \dir -> do
-    let out = dir </> takeFileName filename <.> "out"
-    dflags <- pure $ addOptP "-D__GHCIDE__" dflags
-
-    case contents of
-        Nothing -> do
-            -- Happy case, file is not modified, so run CPP on it in-place
-            -- which also makes things like relative #include files work
-            -- and means location information is correct
-            doCpp dflags True filename out
-            liftIO $ SB.hGetStringBuffer out
-
-        Just contents -> do
-            -- Sad path, we have to create a version of the path in a temp dir
-            -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
-
-            -- Relative includes aren't going to work, so we fix that by adding to the include path.
-            dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
-
-            -- Location information is wrong, so we fix that by patching it afterwards.
-            let inp = dir </> "___GHCIDE_MAGIC___"
-            withBinaryFile inp WriteMode $ \h ->
-                hPutStringBuffer h contents
-            doCpp dflags True inp out
-
-            -- Fix up the filename in lines like:
-            -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
-            let tweak x
-                    | Just x <- stripPrefix "# " x
-                    , "___GHCIDE_MAGIC___" `isInfixOf` x
-                    , let num = takeWhile (not . isSpace) x
-                    -- important to use /, and never \ for paths, even on Windows, since then C escapes them
-                    -- and GHC gets all confused
-                        = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
-                    | otherwise = x
-            stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
-
-
--- | Run a preprocessor on a file
-runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
-runPreprocessor dflags filename contents = withTempDir $ \dir -> do
-    let out = dir </> takeFileName filename <.> "out"
-    inp <- case contents of
-        Nothing -> return filename
-        Just contents -> do
-            let inp = dir </> takeFileName filename <.> "hs"
-            withBinaryFile inp WriteMode $ \h ->
-                hPutStringBuffer h contents
-            return inp
-    runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]
-    SB.hGetStringBuffer out
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.Core.Preprocessor+  ( preprocessor+  ) where++import Development.IDE.GHC.CPP+import Development.IDE.GHC.Orphans()+import Development.IDE.GHC.Compat+import GhcMonad+import StringBuffer as SB++import Data.List.Extra+import System.FilePath+import System.IO.Extra+import Data.Char+import qualified HeaderInfo as Hdr+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.IDE.GHC.Error+import SysTools (Option (..), runUnlit, runPp)+import Control.Monad.Trans.Except+import qualified GHC.LanguageExtensions as LangExt+import Data.Maybe+import Control.Exception.Safe (catch, throw)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import Data.Text (Text)+import qualified Data.Text as T+import Outputable (showSDoc)+import Control.DeepSeq (NFData(rnf))+import Control.Exception (evaluate)+import HscTypes (HscEnv(hsc_dflags))+++-- | Given a file and some contents, apply any necessary preprocessors,+--   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.+preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)+preprocessor env filename mbContents = do+    -- Perform unlit+    (isOnDisk, contents) <-+        if isLiterate filename then do+            let dflags = hsc_dflags env+            newcontent <- liftIO $ runLhs dflags filename mbContents+            return (False, newcontent)+        else do+            contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents+            let isOnDisk = isNothing mbContents+            return (isOnDisk, contents)++    -- Perform cpp+    dflags  <- ExceptT $ parsePragmasIntoDynFlags env filename contents+    (isOnDisk, contents, dflags) <-+        if not $ xopt LangExt.Cpp dflags then+            return (isOnDisk, contents, dflags)+        else do+            cppLogs <- liftIO $ newIORef []+            contents <- ExceptT+                        $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename+                                       $ if isOnDisk then Nothing else Just contents))+                            `catch`+                            ( \(e :: GhcException) -> do+                                logs <- readIORef cppLogs+                                case diagsFromCPPLogs filename (reverse logs) of+                                  [] -> throw e+                                  diags -> return $ Left diags+                            )+            dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents+            return (False, contents, dflags)++    -- Perform preprocessor+    if not $ gopt Opt_Pp dflags then+        return (contents, dflags)+    else do+        contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents+        dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents+        return (contents, dflags)+  where+    logAction :: IORef [CPPLog] -> LogAction+    logAction cppLogs dflags _reason severity srcSpan _style msg = do+      let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg+      modifyIORef cppLogs (log :)+++data CPPLog = CPPLog Severity SrcSpan Text+  deriving (Show)+++data CPPDiag+  = CPPDiag+      { cdRange :: Range,+        cdSeverity :: Maybe DiagnosticSeverity,+        cdMessage :: [Text]+      }+  deriving (Show)+++diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]+diagsFromCPPLogs filename logs =+  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $+    go [] logs+  where+    -- On errors, CPP calls logAction with a real span for the initial log and+    -- then additional informational logs with `UnhelpfulSpan`. Collect those+    -- informational log messages and attaches them to the initial log message.+    go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]+    go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc+    go acc (CPPLog sev (RealSrcSpan span) msg : logs) =+      let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]+       in go (diag : acc) logs+    go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =+      go (diag {cdMessage = msg : cdMessage diag} : diags) logs+    go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs+    cppDiagToDiagnostic :: CPPDiag -> Diagnostic+    cppDiagToDiagnostic d =+      Diagnostic+        { _range = cdRange d,+          _severity = cdSeverity d,+          _code = Nothing,+          _source = Just "CPP",+          _message = T.unlines $ cdMessage d,+          _relatedInformation = Nothing,+          _tags = Nothing+        }+++isLiterate :: FilePath -> Bool+isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]+++-- | This reads the pragma information directly from the provided buffer.+parsePragmasIntoDynFlags+    :: HscEnv+    -> FilePath+    -> SB.StringBuffer+    -> IO (Either [FileDiagnostic] DynFlags)+parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do+    let opts = Hdr.getOptions dflags0 contents fp++    -- Force bits that might keep the dflags and stringBuffer alive unnecessarily+    evaluate $ rnf opts++    (dflags, _, _) <- parseDynamicFilePragma dflags0 opts+    dflags' <- initializePlugins env dflags+    return $ disableWarningsAsErrors dflags'+  where dflags0 = hsc_dflags env++-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set+runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runLhs dflags filename contents = withTempDir $ \dir -> do+    let fout = dir </> takeFileName filename <.> "unlit"+    filesrc <- case contents of+        Nothing   -> return filename+        Just cnts -> do+            let fsrc = dir </> takeFileName filename <.> "literate"+            withBinaryFile fsrc WriteMode $ \h ->+                hPutStringBuffer h cnts+            return fsrc+    unlit filesrc fout+    SB.hGetStringBuffer fout+  where+    unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)+    args filein fileout = [+                      SysTools.Option     "-h"+                    , SysTools.Option     (escape filename) -- name this file+                    , SysTools.FileOption "" filein       -- input file+                    , SysTools.FileOption "" fileout ]    -- output file+    -- taken from ghc's DriverPipeline.hs+    escape ('\\':cs) = '\\':'\\': escape cs+    escape ('\"':cs) = '\\':'\"': escape cs+    escape ('\'':cs) = '\\':'\'': escape cs+    escape (c:cs)    = c : escape cs+    escape []        = []++-- | Run CPP on a file+runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runCpp dflags filename contents = withTempDir $ \dir -> do+    let out = dir </> takeFileName filename <.> "out"+    dflags <- pure $ addOptP "-D__GHCIDE__" dflags++    case contents of+        Nothing -> do+            -- Happy case, file is not modified, so run CPP on it in-place+            -- which also makes things like relative #include files work+            -- and means location information is correct+            doCpp dflags True filename out+            liftIO $ SB.hGetStringBuffer out++        Just contents -> do+            -- Sad path, we have to create a version of the path in a temp dir+            -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)++            -- Relative includes aren't going to work, so we fix that by adding to the include path.+            dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags++            -- Location information is wrong, so we fix that by patching it afterwards.+            let inp = dir </> "___GHCIDE_MAGIC___"+            withBinaryFile inp WriteMode $ \h ->+                hPutStringBuffer h contents+            doCpp dflags True inp out++            -- Fix up the filename in lines like:+            -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"+            let tweak x+                    | Just x <- stripPrefix "# " x+                    , "___GHCIDE_MAGIC___" `isInfixOf` x+                    , let num = takeWhile (not . isSpace) x+                    -- important to use /, and never \ for paths, even on Windows, since then C escapes them+                    -- and GHC gets all confused+                        = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""+                    | otherwise = x+            stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out+++-- | Run a preprocessor on a file+runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runPreprocessor dflags filename contents = withTempDir $ \dir -> do+    let out = dir </> takeFileName filename <.> "out"+    inp <- case contents of+        Nothing -> return filename+        Just contents -> do+            let inp = dir </> takeFileName filename <.> "hs"+            withBinaryFile inp WriteMode $ \h ->+                hPutStringBuffer h contents+            return inp+    runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]+    SB.hGetStringBuffer out
src/Development/IDE/Core/RuleTypes.hs view
@@ -1,400 +1,436 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DerivingStrategies #-}
-
--- | A Shake implementation of the compiler service, built
---   using the "Shaker" abstraction layer for in-memory use.
---
-module Development.IDE.Core.RuleTypes(
-    module Development.IDE.Core.RuleTypes
-    ) where
-
-import           Control.DeepSeq
-import Data.Aeson.Types (Value)
-import Data.Binary
-import           Development.IDE.Import.DependencyInformation
-import Development.IDE.GHC.Compat hiding (HieFileResult)
-import Development.IDE.GHC.Util
-import Development.IDE.Types.KnownTargets
-import           Data.Hashable
-import           Data.Typeable
-import qualified Data.Set as S
-import qualified Data.Map as M
-import           Development.Shake
-import           GHC.Generics                             (Generic)
-
-import Module (InstalledUnitId)
-import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable)
-
-import           Development.IDE.Spans.Common
-import           Development.IDE.Spans.LocalBindings
-import           Development.IDE.Import.FindImports (ArtifactsLocation)
-import Data.ByteString (ByteString)
-import Language.Haskell.LSP.Types (NormalizedFilePath)
-import TcRnMonad (TcGblEnv)
-import qualified Data.ByteString.Char8 as BS
-import Development.IDE.Types.Options (IdeGhcSession)
-import Data.Text (Text)
-import Data.Int (Int64)
-
-data LinkableType = ObjectLinkable | BCOLinkable
-  deriving (Eq,Ord,Show)
-
--- NOTATION
---   Foo+ means Foo for the dependencies
---   Foo* means Foo for me and Foo+
-
--- | The parse tree for the file using GetFileContents
-type instance RuleResult GetParsedModule = ParsedModule
-
--- | The dependency information produced by following the imports recursively.
--- This rule will succeed even if there is an error, e.g., a module could not be located,
--- a module could not be parsed or an import cycle.
-type instance RuleResult GetDependencyInformation = DependencyInformation
-
--- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation.
--- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure.
-type instance RuleResult GetDependencies = TransitiveDependencies
-
-type instance RuleResult GetModuleGraph = DependencyInformation
-
-data GetKnownTargets = GetKnownTargets
-  deriving (Show, Generic, Eq, Ord)
-instance Hashable GetKnownTargets
-instance NFData   GetKnownTargets
-instance Binary   GetKnownTargets
-type instance RuleResult GetKnownTargets = KnownTargets
-
--- | Convert to Core, requires TypeCheck*
-type instance RuleResult GenerateCore = ModGuts
-
-data GenerateCore = GenerateCore
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GenerateCore
-instance NFData   GenerateCore
-instance Binary   GenerateCore
-
-data GetImportMap = GetImportMap
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetImportMap
-instance NFData   GetImportMap
-instance Binary   GetImportMap
-
-type instance RuleResult GetImportMap = ImportMap
-newtype ImportMap = ImportMap
-  { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located?
-  } deriving stock Show
-    deriving newtype NFData
-
--- | Contains the typechecked module and the OrigNameCache entry for
--- that module.
-data TcModuleResult = TcModuleResult
-    { tmrParsed :: ParsedModule
-    , tmrRenamed :: RenamedSource
-    , tmrTypechecked :: TcGblEnv
-    , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
-    }
-instance Show TcModuleResult where
-    show = show . pm_mod_summary . tmrParsed
-
-instance NFData TcModuleResult where
-    rnf = rwhnf
-
-tmrModSummary :: TcModuleResult -> ModSummary
-tmrModSummary = pm_mod_summary . tmrParsed
-
-data HiFileResult = HiFileResult
-    { hirModSummary :: !ModSummary
-    -- Bang patterns here are important to stop the result retaining
-    -- a reference to a typechecked module
-    , hirHomeMod :: !HomeModInfo
-    -- ^ Includes the Linkable iff we need object files
-    }
-
-hiFileFingerPrint :: HiFileResult -> ByteString
-hiFileFingerPrint hfr = ifaceBS <> linkableBS
-  where
-    ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes
-    linkableBS = case hm_linkable $ hirHomeMod hfr of
-      Nothing -> ""
-      Just l -> BS.pack $ show $ linkableTime l
-
-hirModIface :: HiFileResult -> ModIface
-hirModIface = hm_iface . hirHomeMod
-
-instance NFData HiFileResult where
-    rnf = rwhnf
-
-instance Show HiFileResult where
-    show = show . hirModSummary
-
--- | Save the uncompressed AST here, we compress it just before writing to disk
-data HieAstResult
-  = HAR
-  { hieModule :: Module
-  , hieAst :: !(HieASTs Type)
-  , refMap :: RefMap
-  -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type
-  -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same
-  -- as that of `hieAst`
-  }
-
-instance NFData HieAstResult where
-    rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf
-
-instance Show HieAstResult where
-    show = show . hieModule
-
--- | The type checked version of this file, requires TypeCheck+
-type instance RuleResult TypeCheck = TcModuleResult
-
--- | The uncompressed HieAST
-type instance RuleResult GetHieAst = HieAstResult
-
--- | A IntervalMap telling us what is in scope at each point
-type instance RuleResult GetBindings = Bindings
-
-data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap}
-instance NFData DocAndKindMap where
-    rnf (DKMap a b) = rwhnf a `seq` rwhnf b
-
-instance Show DocAndKindMap where
-    show = const "docmap"
-
-type instance RuleResult GetDocMap = DocAndKindMap
-
--- | A GHC session that we reuse.
-type instance RuleResult GhcSession = HscEnvEq
-
--- | A GHC session preloaded with all the dependencies
-type instance RuleResult GhcSessionDeps = HscEnvEq
-
--- | Resolve the imports in a module to the file path of a module
--- in the same package or the package id of another package.
-type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
-
--- | This rule is used to report import cycles. It depends on GetDependencyInformation.
--- We cannot report the cycles directly from GetDependencyInformation since
--- we can only report diagnostics for the current file.
-type instance RuleResult ReportImportCycles = ()
-
--- | Read the module interface file from disk. Throws an error for VFS files.
---   This is an internal rule, use 'GetModIface' instead.
-type instance RuleResult GetModIfaceFromDisk = HiFileResult
-
--- | Get a module interface details, either from an interface file or a typechecked module
-type instance RuleResult GetModIface = HiFileResult
-
--- | Get a module interface details, without the Linkable
--- For better early cuttoff
-type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult
-
--- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
-type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
-
--- The Shake key type for getModificationTime queries
-data GetModificationTime = GetModificationTime_
-    { missingFileDiagnostics :: Bool
-      -- ^ If false, missing file diagnostics are not reported
-    }
-    deriving (Show, Generic)
-
-instance Eq GetModificationTime where
-    -- Since the diagnostics are not part of the answer, the query identity is
-    -- independent from the 'missingFileDiagnostics' field
-    _ == _ = True
-
-instance Hashable GetModificationTime where
-    -- Since the diagnostics are not part of the answer, the query identity is
-    -- independent from the 'missingFileDiagnostics' field
-    hashWithSalt salt _ = salt
-
-instance NFData   GetModificationTime
-instance Binary   GetModificationTime
-
-pattern GetModificationTime :: GetModificationTime
-pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
-
--- | Get the modification time of a file.
-type instance RuleResult GetModificationTime = FileVersion
-
-data FileVersion
-    = VFSVersion !Int
-    | ModificationTime
-      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)
-      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)
-    deriving (Show, Generic)
-
-instance NFData FileVersion
-
-vfsVersion :: FileVersion -> Maybe Int
-vfsVersion (VFSVersion i) = Just i
-vfsVersion ModificationTime{} = Nothing
-
-data GetFileContents = GetFileContents
-    deriving (Eq, Show, Generic)
-instance Hashable GetFileContents
-instance NFData   GetFileContents
-instance Binary   GetFileContents
-
-
-data FileOfInterestStatus = OnDisk | Modified
-  deriving (Eq, Show, Typeable, Generic)
-instance Hashable FileOfInterestStatus
-instance NFData   FileOfInterestStatus
-instance Binary   FileOfInterestStatus
-
-data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus
-  deriving (Eq, Show, Typeable, Generic)
-instance Hashable IsFileOfInterestResult
-instance NFData   IsFileOfInterestResult
-instance Binary   IsFileOfInterestResult
-
-type instance RuleResult IsFileOfInterest = IsFileOfInterestResult
-
--- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.
--- without needing to parse the entire source
-type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs])
-
--- | Generate a ModSummary with the timestamps elided,
---   for more successful early cutoff
-type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs])
-
-data GetParsedModule = GetParsedModule
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetParsedModule
-instance NFData   GetParsedModule
-instance Binary   GetParsedModule
-
-data GetLocatedImports = GetLocatedImports
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetLocatedImports
-instance NFData   GetLocatedImports
-instance Binary   GetLocatedImports
-
--- | Does this module need to be compiled?
-type instance RuleResult NeedsCompilation = Bool
-
-data NeedsCompilation = NeedsCompilation
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable NeedsCompilation
-instance NFData   NeedsCompilation
-instance Binary   NeedsCompilation
-
-data GetDependencyInformation = GetDependencyInformation
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetDependencyInformation
-instance NFData   GetDependencyInformation
-instance Binary   GetDependencyInformation
-
-data GetModuleGraph = GetModuleGraph
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModuleGraph
-instance NFData   GetModuleGraph
-instance Binary   GetModuleGraph
-
-data ReportImportCycles = ReportImportCycles
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable ReportImportCycles
-instance NFData   ReportImportCycles
-instance Binary   ReportImportCycles
-
-data GetDependencies = GetDependencies
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetDependencies
-instance NFData   GetDependencies
-instance Binary   GetDependencies
-
-data TypeCheck = TypeCheck
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable TypeCheck
-instance NFData   TypeCheck
-instance Binary   TypeCheck
-
-data GetDocMap = GetDocMap
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetDocMap
-instance NFData   GetDocMap
-instance Binary   GetDocMap
-
-data GetHieAst = GetHieAst
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetHieAst
-instance NFData   GetHieAst
-instance Binary   GetHieAst
-
-data GetBindings = GetBindings
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetBindings
-instance NFData   GetBindings
-instance Binary   GetBindings
-
-data GhcSession = GhcSession
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GhcSession
-instance NFData   GhcSession
-instance Binary   GhcSession
-
-data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic)
-instance Hashable GhcSessionDeps
-instance NFData   GhcSessionDeps
-instance Binary   GhcSessionDeps
-
-data GetModIfaceFromDisk = GetModIfaceFromDisk
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModIfaceFromDisk
-instance NFData   GetModIfaceFromDisk
-instance Binary   GetModIfaceFromDisk
-
-data GetModIface = GetModIface
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModIface
-instance NFData   GetModIface
-instance Binary   GetModIface
-
-data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModIfaceWithoutLinkable
-instance NFData   GetModIfaceWithoutLinkable
-instance Binary   GetModIfaceWithoutLinkable
-
-data IsFileOfInterest = IsFileOfInterest
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable IsFileOfInterest
-instance NFData   IsFileOfInterest
-instance Binary   IsFileOfInterest
-
-data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModSummaryWithoutTimestamps
-instance NFData   GetModSummaryWithoutTimestamps
-instance Binary   GetModSummaryWithoutTimestamps
-
-data GetModSummary = GetModSummary
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetModSummary
-instance NFData   GetModSummary
-instance Binary   GetModSummary
-
--- | Get the vscode client settings stored in the ide state
-data GetClientSettings = GetClientSettings
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetClientSettings
-instance NFData   GetClientSettings
-instance Binary   GetClientSettings
-
-type instance RuleResult GetClientSettings = Hashed (Maybe Value)
-
--- A local rule type to get caching. We want to use newCache, but it has
--- thread killed exception issues, so we lift it to a full rule.
--- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
-type instance RuleResult GhcSessionIO = IdeGhcSession
-
-data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
-instance Hashable GhcSessionIO
-instance NFData   GhcSessionIO
-instance Binary   GhcSessionIO
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DerivingStrategies #-}++-- | A Shake implementation of the compiler service, built+--   using the "Shaker" abstraction layer for in-memory use.+--+module Development.IDE.Core.RuleTypes(+    module Development.IDE.Core.RuleTypes+    ) where++import           Control.DeepSeq+import Control.Lens+import Data.Aeson.Types (Value)+import Data.Binary+import           Development.IDE.Import.DependencyInformation+import Development.IDE.GHC.Compat hiding (HieFileResult)+import Development.IDE.GHC.Util+import Development.IDE.Types.KnownTargets+import           Data.Hashable+import           Data.Typeable+import qualified Data.Set as S+import qualified Data.Map as M+import           Development.Shake+import           GHC.Generics                             (Generic)++import Module (InstalledUnitId)+import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable)++import           Development.IDE.Spans.Common+import           Development.IDE.Spans.LocalBindings+import           Development.IDE.Import.FindImports (ArtifactsLocation)+import Data.ByteString (ByteString)+import Language.Haskell.LSP.Types (NormalizedFilePath)+import TcRnMonad (TcGblEnv)+import qualified Data.ByteString.Char8 as BS+import Development.IDE.Types.Options (IdeGhcSession)+import Data.Text (Text)+import Data.Int (Int64)+import GHC.Serialized (Serialized)++data LinkableType = ObjectLinkable | BCOLinkable+  deriving (Eq,Ord,Show)++-- NOTATION+--   Foo+ means Foo for the dependencies+--   Foo* means Foo for me and Foo+++-- | The parse tree for the file using GetFileContents+type instance RuleResult GetParsedModule = ParsedModule++-- | The dependency information produced by following the imports recursively.+-- This rule will succeed even if there is an error, e.g., a module could not be located,+-- a module could not be parsed or an import cycle.+type instance RuleResult GetDependencyInformation = DependencyInformation++-- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation.+-- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure.+type instance RuleResult GetDependencies = TransitiveDependencies++type instance RuleResult GetModuleGraph = DependencyInformation++data GetKnownTargets = GetKnownTargets+  deriving (Show, Generic, Eq, Ord)+instance Hashable GetKnownTargets+instance NFData   GetKnownTargets+instance Binary   GetKnownTargets+type instance RuleResult GetKnownTargets = KnownTargets++-- | Convert to Core, requires TypeCheck*+type instance RuleResult GenerateCore = ModGuts++data GenerateCore = GenerateCore+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GenerateCore+instance NFData   GenerateCore+instance Binary   GenerateCore++data GetImportMap = GetImportMap+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetImportMap+instance NFData   GetImportMap+instance Binary   GetImportMap++type instance RuleResult GetImportMap = ImportMap+newtype ImportMap = ImportMap+  { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located?+  } deriving stock Show+    deriving newtype NFData++data Splices = Splices+    { exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)]+    , patSplices :: [(LHsExpr GhcTc, LPat GhcPs)]+    , typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)]+    , declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])]+    , awSplices :: [(LHsExpr GhcTc, Serialized)]+    }++instance Semigroup Splices where+    Splices e p t d aw <> Splices e' p' t' d' aw' =+        Splices+            (e <> e')+            (p <> p')+            (t <> t')+            (d <> d')+            (aw <> aw')++instance Monoid Splices where+    mempty = Splices mempty mempty mempty mempty mempty++instance NFData Splices where+    rnf Splices {..} =+        liftRnf rwhnf exprSplices `seq`+        liftRnf rwhnf patSplices `seq`+        liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` ()++-- | Contains the typechecked module and the OrigNameCache entry for+-- that module.+data TcModuleResult = TcModuleResult+    { tmrParsed :: ParsedModule+    , tmrRenamed :: RenamedSource+    , tmrTypechecked :: TcGblEnv+    , tmrTopLevelSplices :: Splices+    -- ^ Typechecked splice information+    , tmrDeferedError :: !Bool+    -- ^ Did we defer any type errors for this module?+    }+instance Show TcModuleResult where+    show = show . pm_mod_summary . tmrParsed++instance NFData TcModuleResult where+    rnf = rwhnf++tmrModSummary :: TcModuleResult -> ModSummary+tmrModSummary = pm_mod_summary . tmrParsed++data HiFileResult = HiFileResult+    { hirModSummary :: !ModSummary+    -- Bang patterns here are important to stop the result retaining+    -- a reference to a typechecked module+    , hirHomeMod :: !HomeModInfo+    -- ^ Includes the Linkable iff we need object files+    }++hiFileFingerPrint :: HiFileResult -> ByteString+hiFileFingerPrint hfr = ifaceBS <> linkableBS+  where+    ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes+    linkableBS = case hm_linkable $ hirHomeMod hfr of+      Nothing -> ""+      Just l -> BS.pack $ show $ linkableTime l++hirModIface :: HiFileResult -> ModIface+hirModIface = hm_iface . hirHomeMod++instance NFData HiFileResult where+    rnf = rwhnf++instance Show HiFileResult where+    show = show . hirModSummary++-- | Save the uncompressed AST here, we compress it just before writing to disk+data HieAstResult+  = HAR+  { hieModule :: Module+  , hieAst :: !(HieASTs Type)+  , refMap :: RefMap+  -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type+  -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same+  -- as that of `hieAst`+  }++instance NFData HieAstResult where+    rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf++instance Show HieAstResult where+    show = show . hieModule++-- | The type checked version of this file, requires TypeCheck++type instance RuleResult TypeCheck = TcModuleResult++-- | The uncompressed HieAST+type instance RuleResult GetHieAst = HieAstResult++-- | A IntervalMap telling us what is in scope at each point+type instance RuleResult GetBindings = Bindings++data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap}+instance NFData DocAndKindMap where+    rnf (DKMap a b) = rwhnf a `seq` rwhnf b++instance Show DocAndKindMap where+    show = const "docmap"++type instance RuleResult GetDocMap = DocAndKindMap++-- | A GHC session that we reuse.+type instance RuleResult GhcSession = HscEnvEq++-- | A GHC session preloaded with all the dependencies+type instance RuleResult GhcSessionDeps = HscEnvEq++-- | Resolve the imports in a module to the file path of a module+-- in the same package or the package id of another package.+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)++-- | This rule is used to report import cycles. It depends on GetDependencyInformation.+-- We cannot report the cycles directly from GetDependencyInformation since+-- we can only report diagnostics for the current file.+type instance RuleResult ReportImportCycles = ()++-- | Read the module interface file from disk. Throws an error for VFS files.+--   This is an internal rule, use 'GetModIface' instead.+type instance RuleResult GetModIfaceFromDisk = HiFileResult++-- | Get a module interface details, either from an interface file or a typechecked module+type instance RuleResult GetModIface = HiFileResult++-- | Get a module interface details, without the Linkable+-- For better early cuttoff+type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult++-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.+type instance RuleResult GetFileContents = (FileVersion, Maybe Text)++-- The Shake key type for getModificationTime queries+data GetModificationTime = GetModificationTime_+    { missingFileDiagnostics :: Bool+      -- ^ If false, missing file diagnostics are not reported+    }+    deriving (Show, Generic)++instance Eq GetModificationTime where+    -- Since the diagnostics are not part of the answer, the query identity is+    -- independent from the 'missingFileDiagnostics' field+    _ == _ = True++instance Hashable GetModificationTime where+    -- Since the diagnostics are not part of the answer, the query identity is+    -- independent from the 'missingFileDiagnostics' field+    hashWithSalt salt _ = salt++instance NFData   GetModificationTime+instance Binary   GetModificationTime++pattern GetModificationTime :: GetModificationTime+pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}++-- | Get the modification time of a file.+type instance RuleResult GetModificationTime = FileVersion++data FileVersion+    = VFSVersion !Int+    | ModificationTime+      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)+      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)+    deriving (Show, Generic)++instance NFData FileVersion++vfsVersion :: FileVersion -> Maybe Int+vfsVersion (VFSVersion i) = Just i+vfsVersion ModificationTime{} = Nothing++data GetFileContents = GetFileContents+    deriving (Eq, Show, Generic)+instance Hashable GetFileContents+instance NFData   GetFileContents+instance Binary   GetFileContents+++data FileOfInterestStatus = OnDisk | Modified+  deriving (Eq, Show, Typeable, Generic)+instance Hashable FileOfInterestStatus+instance NFData   FileOfInterestStatus+instance Binary   FileOfInterestStatus++data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus+  deriving (Eq, Show, Typeable, Generic)+instance Hashable IsFileOfInterestResult+instance NFData   IsFileOfInterestResult+instance Binary   IsFileOfInterestResult++type instance RuleResult IsFileOfInterest = IsFileOfInterestResult++-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.+-- without needing to parse the entire source+type instance RuleResult GetModSummary = (ModSummary,[LImportDecl GhcPs])++-- | Generate a ModSummary with the timestamps elided,+--   for more successful early cutoff+type instance RuleResult GetModSummaryWithoutTimestamps = (ModSummary,[LImportDecl GhcPs])++data GetParsedModule = GetParsedModule+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetParsedModule+instance NFData   GetParsedModule+instance Binary   GetParsedModule++data GetLocatedImports = GetLocatedImports+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetLocatedImports+instance NFData   GetLocatedImports+instance Binary   GetLocatedImports++-- | Does this module need to be compiled?+type instance RuleResult NeedsCompilation = Bool++data NeedsCompilation = NeedsCompilation+    deriving (Eq, Show, Typeable, Generic)+instance Hashable NeedsCompilation+instance NFData   NeedsCompilation+instance Binary   NeedsCompilation++data GetDependencyInformation = GetDependencyInformation+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetDependencyInformation+instance NFData   GetDependencyInformation+instance Binary   GetDependencyInformation++data GetModuleGraph = GetModuleGraph+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModuleGraph+instance NFData   GetModuleGraph+instance Binary   GetModuleGraph++data ReportImportCycles = ReportImportCycles+    deriving (Eq, Show, Typeable, Generic)+instance Hashable ReportImportCycles+instance NFData   ReportImportCycles+instance Binary   ReportImportCycles++data GetDependencies = GetDependencies+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetDependencies+instance NFData   GetDependencies+instance Binary   GetDependencies++data TypeCheck = TypeCheck+    deriving (Eq, Show, Typeable, Generic)+instance Hashable TypeCheck+instance NFData   TypeCheck+instance Binary   TypeCheck++data GetDocMap = GetDocMap+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetDocMap+instance NFData   GetDocMap+instance Binary   GetDocMap++data GetHieAst = GetHieAst+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetHieAst+instance NFData   GetHieAst+instance Binary   GetHieAst++data GetBindings = GetBindings+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetBindings+instance NFData   GetBindings+instance Binary   GetBindings++data GhcSession = GhcSession+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GhcSession+instance NFData   GhcSession+instance Binary   GhcSession++data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic)+instance Hashable GhcSessionDeps+instance NFData   GhcSessionDeps+instance Binary   GhcSessionDeps++data GetModIfaceFromDisk = GetModIfaceFromDisk+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModIfaceFromDisk+instance NFData   GetModIfaceFromDisk+instance Binary   GetModIfaceFromDisk++data GetModIface = GetModIface+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModIface+instance NFData   GetModIface+instance Binary   GetModIface++data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModIfaceWithoutLinkable+instance NFData   GetModIfaceWithoutLinkable+instance Binary   GetModIfaceWithoutLinkable++data IsFileOfInterest = IsFileOfInterest+    deriving (Eq, Show, Typeable, Generic)+instance Hashable IsFileOfInterest+instance NFData   IsFileOfInterest+instance Binary   IsFileOfInterest++data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModSummaryWithoutTimestamps+instance NFData   GetModSummaryWithoutTimestamps+instance Binary   GetModSummaryWithoutTimestamps++data GetModSummary = GetModSummary+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModSummary+instance NFData   GetModSummary+instance Binary   GetModSummary++-- | Get the vscode client settings stored in the ide state+data GetClientSettings = GetClientSettings+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetClientSettings+instance NFData   GetClientSettings+instance Binary   GetClientSettings++type instance RuleResult GetClientSettings = Hashed (Maybe Value)++-- A local rule type to get caching. We want to use newCache, but it has+-- thread killed exception issues, so we lift it to a full rule.+-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547+type instance RuleResult GhcSessionIO = IdeGhcSession++data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)+instance Hashable GhcSessionIO+instance NFData   GhcSessionIO+instance Binary   GhcSessionIO++makeLensesWith+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+    ''Splices
src/Development/IDE/Core/Rules.hs view
@@ -1,981 +1,1007 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-#include "ghc-api-version.h"
-
--- | A Shake implementation of the compiler service, built
---   using the "Shaker" abstraction layer for in-memory use.
---
-module Development.IDE.Core.Rules(
-    IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
-    Priority(..), GhcSessionIO(..), GetClientSettings(..),
-    priorityTypeCheck,
-    priorityGenerateCore,
-    priorityFilesOfInterest,
-    runAction, useE, useNoFileE, usesE,
-    toIdeResult,
-    defineNoFile,
-    defineEarlyCutOffNoFile,
-    mainRule,
-    getAtPoint,
-    getDefinition,
-    getTypeDefinition,
-    highlightAtPoint,
-    getDependencies,
-    getParsedModule,
-    getClientConfigAction,
-    ) where
-
-import Fingerprint
-
-import Data.Aeson (fromJSON, Result(Success), FromJSON)
-import Data.Binary hiding (get, put)
-import Data.Default
-import Data.Tuple.Extra
-import Control.Monad.Extra
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Development.IDE.Core.Compile
-import Development.IDE.Core.OfInterest
-import Development.IDE.Types.Options
-import Development.IDE.Spans.Documentation
-import Development.IDE.Spans.LocalBindings
-import Development.IDE.Import.DependencyInformation
-import Development.IDE.Import.FindImports
-import           Development.IDE.Core.FileExists
-import           Development.IDE.Core.FileStore        (modificationTime, getFileContents)
-import           Development.IDE.Types.Diagnostics as Diag
-import Development.IDE.Types.Location
-import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile)
-import Development.IDE.GHC.Util
-import Data.Either.Extra
-import qualified Development.IDE.Types.Logger as L
-import Data.Maybe
-import           Data.Foldable
-import qualified Data.IntMap.Strict as IntMap
-import Data.IntMap.Strict (IntMap)
-import Data.List
-import qualified Data.Set                                 as Set
-import qualified Data.Map as M
-import qualified Data.Text                                as T
-import qualified Data.Text.Encoding                       as T
-import           Development.IDE.GHC.Error
-import           Development.Shake                        hiding (Diagnostic)
-import Development.IDE.Core.RuleTypes
-import qualified Data.ByteString.Char8 as BS
-import Development.IDE.Core.PositionMapping
-import           Language.Haskell.LSP.Types (DocumentHighlight (..))
-
-import qualified GHC.LanguageExtensions as LangExt
-import HscTypes hiding (TargetModule, TargetFile)
-import GHC.Generics(Generic)
-
-import qualified Development.IDE.Spans.AtPoint as AtPoint
-import Development.IDE.Core.IdeConfiguration
-import Development.IDE.Core.Service
-import Development.IDE.Core.Shake
-import Development.Shake.Classes hiding (get, put)
-import Control.Monad.Trans.Except (runExceptT)
-import Data.ByteString (ByteString)
-import Control.Concurrent.Async (concurrently)
-import System.Time.Extra
-import Control.Monad.Reader
-import System.Directory ( getModificationTime )
-import Control.Exception
-
-import Control.Monad.State
-import FastString (FastString(uniq))
-import qualified HeaderInfo as Hdr
-import Data.Time (UTCTime(..))
-import Data.Hashable
-import qualified Data.HashSet as HashSet
-import qualified Data.HashMap.Strict as HM
-import TcRnMonad (tcg_dependent_files)
-import Data.IORef
-import Control.Concurrent.Extra
-import Module
-
--- | 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
--- warnings while also producing a result.
-toIdeResult :: Either [FileDiagnostic] v -> IdeResult v
-toIdeResult = either (, Nothing) (([],) . Just)
-
--- | useE is useful to implement functions that aren’t rules but need shortcircuiting
--- e.g. getDefinition.
-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
-useE k = MaybeT . useWithStaleFast k
-
-useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v
-useNoFileE _ide k = fst <$> useE k emptyFilePath
-
-usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]
-usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)
-
-defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
-defineNoFile f = define $ \k file -> do
-    if file == emptyFilePath then do res <- f k; return ([], Just res) else
-        fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
-
-defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules ()
-defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do
-    if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else
-        fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
-
-
-------------------------------------------------------------
--- Exposed API
-
--- | Get all transitive file dependencies of a given module.
--- Does not include the file itself.
-getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
-getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
-
--- | Try to get hover text for the name under point.
-getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
-getAtPoint file pos = fmap join $ runMaybeT $ do
-  ide <- ask
-  opts <- liftIO $ getIdeOptionsIO ide
-
-  (hieAst -> hf, mapping) <- useE GetHieAst file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)
-
-  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  return $ AtPoint.atPoint opts hf dkMap pos'
-
--- | Goto Definition.
-getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
-getDefinition file pos = runMaybeT $ do
-    ide <- ask
-    opts <- liftIO $ getIdeOptionsIO ide
-    (HAR _ hf _ , mapping) <- useE GetHieAst file
-    (ImportMap imports, _) <- useE GetImportMap file
-    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos'
-
-getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
-getTypeDefinition file pos = runMaybeT $ do
-    ide <- ask
-    opts <- liftIO $ getIdeOptionsIO ide
-    (hieAst -> hf, mapping) <- useE GetHieAst file
-    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos'
-
-highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
-highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf,mapping) <- useE GetHieAst file
-    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    AtPoint.documentHighlight hf rf pos'
-
-getHieFile
-  :: ShakeExtras
-  -> NormalizedFilePath -- ^ file we're editing
-  -> Module -- ^ module dep we want info for
-  -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module
-getHieFile ide file mod = do
-  TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file
-  case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
-    Just NamedModuleDep{nmdFilePath=nfp} -> do
-        let modPath = fromNormalizedFilePath nfp
-        hieFile <- getHomeHieFile nfp
-        return (hieFile, modPath)
-    _ -> getPackageHieFile ide mod file
-
-getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile
-getHomeHieFile f = do
-  ms <- fst . fst <$> useE GetModSummaryWithoutTimestamps f
-  let normal_hie_f = toNormalizedFilePath' hie_f
-      hie_f = ml_hie_file $ ms_location ms
-
-  mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f)
-  srcTimestamp   <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f))
-  liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f)
-  let isUpToDate
-        | Just d <- mbHieTimestamp = d > srcTimestamp
-        | otherwise = False
-
-  if isUpToDate
-    then do
-      ncu <- mkUpdater
-      hf <- liftIO $ whenMaybe isUpToDate (loadHieFile ncu hie_f)
-      MaybeT $ return hf
-    else do
-      wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
-        hsc <- hscEnv <$> use_ GhcSession f
-        pm <- use_ GetParsedModule f
-        (_, mtm)<- typeCheckRuleDefinition hsc pm
-        mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk
-      _ <- MaybeT $ liftIO $ timeout 1 wait
-      ncu <- mkUpdater
-      liftIO $ loadHieFile ncu hie_f
-
-getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
-getSourceFileSource nfp = do
-    (_, msource) <- getFileContents nfp
-    case msource of
-        Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)
-        Just source -> pure $ T.encodeUtf8 source
-
-getPackageHieFile :: ShakeExtras
-                  -> Module             -- ^ Package Module to load .hie file for
-                  -> NormalizedFilePath -- ^ Path of home module importing the package module
-                  -> MaybeT IdeAction (HieFile, FilePath)
-getPackageHieFile ide mod file = do
-    pkgState  <- hscEnv . fst <$> useE GhcSession file
-    IdeOptions {..} <- liftIO $ getIdeOptionsIO ide
-    let unitId = moduleUnitId mod
-    case lookupPackageConfig unitId pkgState of
-        Just pkgConfig -> do
-            -- 'optLocateHieFile' returns Nothing if the file does not exist
-            hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
-            path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
-            case (hieFile, path) of
-                (Just hiePath, Just modPath) -> do
-                    -- deliberately loaded outside the Shake graph
-                    -- to avoid dependencies on non-workspace files
-                        ncu <- mkUpdater
-                        MaybeT $ liftIO $ Just . (, modPath) <$> loadHieFile ncu hiePath
-                _ -> MaybeT $ return Nothing
-        _ -> MaybeT $ return Nothing
-
--- | Parse the contents of a daml file.
-getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
-getParsedModule file = use GetParsedModule file
-
-------------------------------------------------------------
--- Rules
--- These typically go from key to value and are oracles.
-
-priorityTypeCheck :: Priority
-priorityTypeCheck = Priority 0
-
-priorityGenerateCore :: Priority
-priorityGenerateCore = Priority (-1)
-
-priorityFilesOfInterest :: Priority
-priorityFilesOfInterest = Priority (-2)
-
--- | IMPORTANT FOR HLINT INTEGRATION:
--- We currently parse the module both with and without Opt_Haddock, and
--- return the one with Haddocks if it -- succeeds. However, this may not work
--- for hlint, and we might need to save the one without haddocks too.
--- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197
--- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
-getParsedModuleRule :: Rules ()
-getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
-    (ms, _) <- use_ GetModSummary file
-    sess <- use_ GhcSession file
-    let hsc = hscEnv sess
-    opt <- getIdeOptions
-
-    let dflags    = ms_hspp_opts ms
-        mainParse = getParsedModuleDefinition hsc opt file ms
-
-    -- Parse again (if necessary) to capture Haddock parse errors
-    res@(_, (_,pmod)) <- if gopt Opt_Haddock dflags
-        then
-            liftIO mainParse
-        else do
-            let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)
-
-            -- parse twice, with and without Haddocks, concurrently
-            -- we cannot ignore Haddock parse errors because files of
-            -- non-interest are always parsed with Haddocks
-            -- If we can parse Haddocks, might as well use them
-            --
-            -- HLINT INTEGRATION: might need to save the other parsed module too
-            ((fp,(diags,res)),(fph,(diagsh,resh))) <- liftIO $ concurrently mainParse haddockParse
-
-            -- Merge haddock and regular diagnostics so we can always report haddock
-            -- parse errors
-            let diagsM = mergeParseErrorsHaddock diags diagsh
-            case resh of
-              Just _
-                | HaddockParse <- optHaddockParse opt
-                -> pure (fph, (diagsM, resh))
-              -- If we fail to parse haddocks, report the haddock diagnostics as well and
-              -- return the non-haddock parse.
-              -- This seems to be the correct behaviour because the Haddock flag is added
-              -- by us and not the user, so our IDE shouldn't stop working because of it.
-              _ -> pure (fp, (diagsM, res))
-    -- Add dependencies on included files
-    _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod)
-    pure res
-
-withOptHaddock :: ModSummary -> ModSummary
-withOptHaddock ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) Opt_Haddock}
-
-
--- | Given some normal parse errors (first) and some from Haddock (second), merge them.
---   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.
-mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
-mergeParseErrorsHaddock normal haddock = normal ++
-    [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c})
-    | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations]
-  where
-    locations = Set.fromList $ map (Diag._range . thd3) normal
-
-    fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x
-                 | otherwise = "Haddock: " <> x
-
-getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
-getParsedModuleDefinition packageState opt file ms = do
-    let fp = fromNormalizedFilePath file
-    (diag, res) <- parseModule opt packageState fp ms
-    case res of
-        Nothing -> pure (Nothing, (diag, Nothing))
-        Just modu -> do
-            mbFingerprint <- traverse (fmap fingerprintToBS . fingerprintFromStringBuffer) (ms_hspp_buf ms)
-            pure (mbFingerprint, (diag, Just modu))
-
-getLocatedImportsRule :: Rules ()
-getLocatedImportsRule =
-    define $ \GetLocatedImports file -> do
-        (ms,_) <- use_ GetModSummaryWithoutTimestamps file
-        targets <- useNoFile_ GetKnownTargets
-        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
-        let import_dirs = deps env_eq
-        let dflags = hsc_dflags env
-            isImplicitCradle = isNothing $ envImportPaths env_eq
-        dflags <- return $ if isImplicitCradle
-                    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
-        (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
-            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource
-            case diagOrImp of
-                Left diags -> pure (diags, Left (modName, Nothing))
-                Right (FileImport path) -> pure ([], Left (modName, Just path))
-                Right (PackageImport pkgId) -> liftIO $ do
-                    diagsOrPkgDeps <- computePackageDeps env pkgId
-                    case diagsOrPkgDeps of
-                        Left diags -> pure (diags, Right Nothing)
-                        Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)
-        let (moduleImports, pkgImports) = partitionEithers imports'
-        case sequence pkgImports of
-            Nothing -> pure (concat diags, Nothing)
-            Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
-
-type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
-
-execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
-execRawDepM act =
-    execStateT act
-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
-        , IntMap.empty
-        )
-
--- | Given a target file path, construct the raw dependency results by following
--- imports recursively.
-rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
-rawDependencyInformation fs = do
-    (rdi, ss) <- execRawDepM (mapM_ go fs)
-    let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
-    return (rdi { rawBootMap = bm })
-  where
-    go :: NormalizedFilePath -- ^ Current module being processed
-       -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
-    go f = do
-      -- First check to see if we have already processed the FilePath
-      -- If we have, just return its Id but don't update any of the state.
-      -- Otherwise, we need to process its imports.
-      checkAlreadyProcessed f $ do
-          msum <- lift $ fmap fst <$> use GetModSummaryWithoutTimestamps f
-          let al =  modSummaryToArtifactsLocation f msum
-          -- Get a fresh FilePathId for the new file
-          fId <- getFreshFid al
-          -- Adding an edge to the bootmap so we can make sure to
-          -- insert boot nodes before the real files.
-          addBootMap al fId
-          -- Try to parse the imports of the file
-          importsOrErr <- lift $ use GetLocatedImports f
-          case importsOrErr of
-            Nothing -> do
-            -- File doesn't parse so add the module as a failure into the
-            -- dependency information, continue processing the other
-            -- elements in the queue
-              modifyRawDepInfo (insertImport fId (Left ModuleParseError))
-              return fId
-            Just (modImports, pkgImports) -> do
-              -- Get NFPs of the imports which have corresponding files
-              -- Imports either come locally from a file or from a package.
-              let (no_file, with_file) = splitImports modImports
-                  (mns, ls) = unzip with_file
-              -- Recursively process all the imports we just learnt about
-              -- and get back a list of their FilePathIds
-              fids <- mapM (go . artifactFilePath) ls
-              -- Associate together the ModuleName with the FilePathId
-              let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
-              -- Insert into the map the information about this modules
-              -- imports.
-              modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
-              return fId
-
-
-    checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
-    checkAlreadyProcessed nfp k = do
-      (rawDepInfo, _) <- get
-      maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
-
-    modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
-    modifyRawDepInfo f = modify (first f)
-
-    addBootMap ::  ArtifactsLocation -> FilePathId -> RawDepM ()
-    addBootMap al fId =
-      modify (\(rd, ss) -> (rd, if isBootLocation al
-                                  then IntMap.insert (getFilePathId fId) al ss
-                                  else ss))
-
-    getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
-    getFreshFid al = do
-      (rawDepInfo, ss) <- get
-      let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
-      -- Insert the File into the bootmap if it's a boot module
-      let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
-      put (rawDepInfo', ss)
-      return fId
-
-    -- Split in (package imports, local imports)
-    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
-                 -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
-    splitImports = foldr splitImportsLoop ([],[])
-
-    splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
-    splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
-
-    updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
-      if not artifactIsSource
-        then
-          let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath)
-          in case msource_mod_id of
-               Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
-               Nothing -> bm
-        else bm
-
-    dropBootSuffix :: FilePath -> FilePath
-    dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src
-
-getDependencyInformationRule :: Rules ()
-getDependencyInformationRule =
-    define $ \GetDependencyInformation file -> do
-       rawDepInfo <- rawDependencyInformation [file]
-       pure ([], Just $ processDependencyInformation rawDepInfo)
-
-reportImportCyclesRule :: Rules ()
-reportImportCyclesRule =
-    define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
-        DependencyInformation{..} <- use_ GetDependencyInformation file
-        let fileId = pathToId depPathIdMap file
-        case IntMap.lookup (getFilePathId fileId) depErrorNodes of
-            Nothing -> pure []
-            Just errs -> do
-                let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)
-                -- Convert cycles of files into cycles of module names
-                forM cycles $ \(imp, files) -> do
-                    modNames <- forM files $ \fileId -> do
-                        let file = idToPath depPathIdMap fileId
-                        getModuleName file
-                    pure $ toDiag imp $ sort modNames
-    where cycleErrorInFile f (PartOfCycle imp fs)
-            | f `elem` fs = Just (imp, fs)
-          cycleErrorInFile _ _ = Nothing
-          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic
-            { _range = rng
-            , _severity = Just DsError
-            , _source = Just "Import cycle detection"
-            , _message = "Cyclic module dependency between " <> showCycle mods
-            , _code = Nothing
-            , _relatedInformation = Nothing
-            , _tags = Nothing
-            }
-            where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)
-                  fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)
-          getModuleName file = do
-           ms <- fst <$> use_ GetModSummaryWithoutTimestamps file
-           pure (moduleNameString . moduleName . ms_mod $ ms)
-          showCycle mods  = T.intercalate ", " (map T.pack mods)
-
--- returns all transitive dependencies in topological order.
--- NOTE: result does not include the argument file.
-getDependenciesRule :: Rules ()
-getDependenciesRule =
-    defineEarlyCutoff $ \GetDependencies file -> do
-        depInfo <- use_ GetDependencyInformation file
-        let allFiles = reachableModules depInfo
-        _ <- uses_ ReportImportCycles allFiles
-        opts <- getIdeOptions
-        let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
-        return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
-
-getHieAstsRule :: Rules ()
-getHieAstsRule =
-    define $ \GetHieAst f -> do
-      tmr <- use_ TypeCheck f
-      hsc <- hscEnv <$> use_ GhcSession f
-      getHieAstRuleDefinition f hsc tmr
-
-getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
-getHieAstRuleDefinition f hsc tmr = do
-  (diags, masts) <- liftIO $ generateHieAsts hsc tmr
-
-  isFoi <- use_ IsFileOfInterest f
-  diagsWrite <- case isFoi of
-    IsFOI Modified -> pure []
-    _ | Just asts <- masts -> do
-          source <- getSourceFileSource f
-          liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source
-    _ -> pure []
-
-  let refmap = generateReferencesMap . getAsts <$> masts
-  pure (diags <> diagsWrite, HAR (ms_mod  $ tmrModSummary tmr) <$> masts <*> refmap)
-
-getImportMapRule :: Rules()
-getImportMapRule = define $ \GetImportMap f -> do
-  im <- use GetLocatedImports f
-  let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports
-  pure ([], ImportMap . mkImports <$> im)
-
-getBindingsRule :: Rules ()
-getBindingsRule =
-  define $ \GetBindings f -> do
-    har <- use_ GetHieAst f
-    pure ([], Just $ bindings $ refMap har)
-
-getDocMapRule :: Rules ()
-getDocMapRule =
-    define $ \GetDocMap file -> do
-      -- Stale data for the scenario where a broken module has previously typechecked
-      -- but we never generated a DocMap for it
-      (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file
-      (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file
-      (refMap -> rf, _)         <- useWithStale_ GetHieAst file
-
--- When possible, rely on the haddocks embedded in our interface files
--- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
-#if !defined(GHC_LIB)
-      let parsedDeps = []
-#else
-      deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file
-      let tdeps = transitiveModuleDeps deps
-      parsedDeps <- uses_ GetParsedModule tdeps
-#endif
-
-      dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc
-      return ([],Just dkMap)
-
--- Typechecks a module.
-typeCheckRule :: Rules ()
-typeCheckRule = define $ \TypeCheck file -> do
-    pm <- use_ GetParsedModule file
-    hsc  <- hscEnv <$> use_ GhcSessionDeps file
-    typeCheckRuleDefinition hsc pm
-
-knownFilesRule :: Rules ()
-knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do
-  alwaysRerun
-  fs <- knownTargets
-  pure (BS.pack (show $ hash fs), unhashed fs)
-
-getModuleGraphRule :: Rules ()
-getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do
-  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
-  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)
-  pure $ processDependencyInformation rawDepInfo
-
--- This is factored out so it can be directly called from the GetModIface
--- rule. Directly calling this rule means that on the initial load we can
--- garbage collect all the intermediate typechecked modules rather than
--- retain the information forever in the shake graph.
-typeCheckRuleDefinition
-    :: HscEnv
-    -> ParsedModule
-    -> Action (IdeResult TcModuleResult)
-typeCheckRuleDefinition hsc pm = do
-  setPriority priorityTypeCheck
-  IdeOptions { optDefer = defer } <- getIdeOptions
-
-  linkables_to_keep <- currentLinkables
-
-  addUsageDependencies $ liftIO $
-    typecheckModule defer hsc linkables_to_keep pm
-  where
-    addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
-    addUsageDependencies a = do
-      r@(_, mtc) <- a
-      forM_ mtc $ \tc -> do
-        used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc
-        void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
-      return r
-
--- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload.
--- Doesn't actually contain the code, since we don't need it to unload
-currentLinkables :: Action [Linkable]
-currentLinkables = do
-    compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-    hm <- liftIO $ readVar compiledLinkables
-    pure $ map go $ moduleEnvToList hm
-  where
-    go (mod, time) = LM time mod []
-
-loadGhcSession :: Rules ()
-loadGhcSession = do
-    -- This function should always be rerun because it tracks changes
-    -- to the version of the collection of HscEnv's.
-    defineEarlyCutOffNoFile $ \GhcSessionIO -> do
-        alwaysRerun
-        opts <- getIdeOptions
-        res <- optGhcSession opts
-
-        let fingerprint = hash (sessionVersion res)
-        return (BS.pack (show fingerprint), res)
-
-    defineEarlyCutoff $ \GhcSession file -> do
-        IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
-        (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file
-
-        -- add the deps to the Shake graph
-        let addDependency fp = do
-                let nfp = toNormalizedFilePath' fp
-                itExists <- getFileExists nfp
-                when itExists $ void $ use_ GetModificationTime nfp
-        mapM_ addDependency deps
-
-        opts <- getIdeOptions
-        let cutoffHash =
-              case optShakeFiles opts of
-                -- optShakeFiles is only set in the DAML case.
-                -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915
-                Just {} -> ""
-                -- Hash the HscEnvEq returned so cutoff if it didn't change
-                -- from last time
-                Nothing -> BS.pack (show (hash (snd val)))
-        return (Just cutoffHash, val)
-
-    define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file
-
-ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
-ghcSessionDepsDefinition file = do
-        env <- use_ GhcSession file
-        let hsc = hscEnv env
-        (ms,_) <- use_ GetModSummaryWithoutTimestamps file
-        deps <- use_ GetDependencies file
-        let tdeps = transitiveModuleDeps deps
-            uses_th_qq =
-              xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
-            dflags = ms_hspp_opts ms
-        ifaces <- if uses_th_qq
-                  then uses_ GetModIface tdeps
-                  else uses_ GetModIfaceWithoutLinkable tdeps
-
-        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
-        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
-        -- Long-term we might just want to change the order returned by GetDependencies
-        let inLoadOrder = reverse (map hirHomeMod ifaces)
-
-        session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc
-
-        res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' []
-        return ([], Just res)
-
-getModIfaceFromDiskRule :: Rules ()
-getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
-  (ms,_) <- use_ GetModSummary f
-  (diags_session, mb_session) <- ghcSessionDepsDefinition f
-  case mb_session of
-      Nothing -> return (Nothing, (diags_session, Nothing))
-      Just session -> do
-        sourceModified <- use_ IsHiFileStable f
-        linkableType <- getLinkableType f
-        r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)
-        case r of
-            (diags, Just x) -> do
-                let fp = Just (hiFileFingerPrint x)
-                return (fp, (diags <> diags_session, Just x))
-            (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))
-
-isHiFileStableRule :: Rules ()
-isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do
-    (ms,_) <- use_ GetModSummaryWithoutTimestamps f
-    let hiFile = toNormalizedFilePath'
-                $ ml_hi_file $ ms_location ms
-    mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile
-    modVersion  <- use_ GetModificationTime f
-    sourceModified <- case mbHiVersion of
-        Nothing -> pure SourceModified
-        Just x ->
-            if modificationTime x < modificationTime modVersion
-                then pure SourceModified
-                else do
-                    (fileImports, _) <- use_ GetLocatedImports f
-                    let imports = fmap artifactFilePath . snd <$> fileImports
-                    deps <- uses_ IsHiFileStable (catMaybes imports)
-                    pure $ if all (== SourceUnmodifiedAndStable) deps
-                           then SourceUnmodifiedAndStable
-                           else SourceUnmodified
-    return (Just (BS.pack $ show sourceModified), ([], Just sourceModified))
-
-getModSummaryRule :: Rules ()
-getModSummaryRule = do
-    defineEarlyCutoff $ \GetModSummary f -> do
-        session <- hscEnv <$> use_ GhcSession f
-        let dflags = hsc_dflags session
-        (modTime, mFileContent) <- getFileContents f
-        let fp = fromNormalizedFilePath f
-        modS <- liftIO $ runExceptT $
-                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
-        case modS of
-            Right res@(ms,_) -> do
-                let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime)
-                return ( Just (BS.pack $ show fingerPrint) , ([], Just res))
-            Left diags -> return (Nothing, (diags, Nothing))
-
-    defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do
-        ms <- use GetModSummary f
-        case ms of
-            Just res@(msWithTimestamps,_) -> do
-                let ms = msWithTimestamps {
-                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",
-                    ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"
-                    }
-                dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
-                let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms)
-                return (Just fp, ([], Just res))
-            Nothing -> return (Nothing, ([], Nothing))
-    where
-        -- Compute a fingerprint from the contents of `ModSummary`,
-        -- eliding the timestamps and other non relevant fields.
-        computeFingerprint f sb dflags ModSummary{..} =
-            let fingerPrint =
-                    ( moduleNameString (moduleName ms_mod)
-                    , ms_hspp_file
-                    , map unLoc opts
-                    , ml_hs_file ms_location
-                    , fingerPrintImports ms_srcimps
-                    , fingerPrintImports ms_textual_imps
-                    )
-                fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))
-                opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f)
-            in fingerPrint
-
-        hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)
-
-
-generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)
-generateCore runSimplifier file = do
-    packageState <- hscEnv <$> use_ GhcSessionDeps file
-    tm <- use_ TypeCheck file
-    setPriority priorityGenerateCore
-    liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)
-
-generateCoreRule :: Rules ()
-generateCoreRule =
-    define $ \GenerateCore -> generateCore (RunSimplifier True)
-
-getModIfaceRule :: Rules ()
-getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do
-#if !defined(GHC_LIB)
-  fileOfInterest <- use_ IsFileOfInterest f
-  res@(_,(_,mhmi)) <- case fileOfInterest of
-    IsFOI status -> do
-      -- Never load from disk for files of interest
-      tmr <- use_ TypeCheck f
-      linkableType <- getLinkableType f
-      hsc <- hscEnv <$> use_ GhcSessionDeps f
-      let compile = fmap ([],) $ use GenerateCore f
-      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr
-      let fp = hiFileFingerPrint <$> hiFile
-      hiDiags <- case hiFile of
-        Just hiFile
-          | OnDisk <- status
-          , not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile
-        _ -> pure []
-      return (fp, (diags++hiDiags, hiFile))
-    NotFOI -> do
-      hiFile <- use GetModIfaceFromDisk f
-      let fp = hiFileFingerPrint <$> hiFile
-      return (fp, ([], hiFile))
-
-  -- Record the linkable so we know not to unload it
-  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do
-      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-      liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time
-  pure res
-#else
-    tm <- use_ TypeCheck f
-    hsc <- hscEnv <$> use_ GhcSessionDeps f
-    (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm
-    let fp = hiFileFingerPrint <$> hiFile
-    return (fp, (diags, hiFile))
-#endif
-
-getModIfaceWithoutLinkableRule :: Rules ()
-getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do
-  mhfr <- use GetModIface f
-  let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr
-      msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f
-  pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr'))
-
-regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult)
-regenerateHiFile sess f ms compNeeded = do
-    let hsc = hscEnv sess
-    opt <- getIdeOptions
-
-    -- Embed haddocks in the interface file
-    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)
-    (diags, mb_pm) <- case mb_pm of
-        Just _ -> return (diags, mb_pm)
-        Nothing -> do
-            -- if parsing fails, try parsing again with Haddock turned off
-            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f ms
-            return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
-    case mb_pm of
-        Nothing -> return (diags, Nothing)
-        Just pm -> do
-            -- Invoke typechecking directly to update it without incurring a dependency
-            -- on the parsed module and the typecheck rules
-            (diags', mtmr) <- typeCheckRuleDefinition hsc pm
-            case mtmr of
-              Nothing -> pure (diags', Nothing)
-              Just tmr -> do
-
-                -- compile writes .o file
-                let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
-
-                -- Bang pattern is important to avoid leaking 'tmr'
-                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr
-
-                -- Write hi file
-                hiDiags <- case res of
-                  Just hiFile
-                    | not $ tmrDeferedError tmr ->
-                      liftIO $ writeHiFile hsc hiFile
-                  _ -> pure []
-
-                -- Write hie file
-                (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr
-                source <- getSourceFileSource f
-                wDiags <- forM masts $ \asts ->
-                  liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source
-
-                return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res)
-
-
-type CompileMod m = m (IdeResult ModGuts)
-
--- | HscEnv should have deps included already
-compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)
-compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do
-  res <- mkHiFileResultNoCompile hsc tmr
-  pure ([], Just $! res)
-compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do
-  (diags, mguts) <- getGuts
-  case mguts of
-    Nothing -> pure (diags, Nothing)
-    Just guts -> do
-      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType
-      pure (diags++diags', res)
-
-getClientSettingsRule :: Rules ()
-getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do
-  alwaysRerun
-  settings <- clientSettings <$> getIdeConfiguration
-  return (BS.pack . show . hash $ settings, settings)
-
--- | Returns the client configurarion stored in the IdeState.
--- You can use this function to access it from shake Rules
-getClientConfigAction :: (Default a, FromJSON a) => Action a
-getClientConfigAction = do
-  mbVal <- unhashed <$> useNoFile_ GetClientSettings
-  case fromJSON <$> mbVal of
-    Just (Success c) -> return c
-    _ -> return def
-
--- | For now we always use bytecode
-getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
-getLinkableType f = do
-  needsComp <- use_ NeedsCompilation f
-  pure $ if needsComp then Just BCOLinkable else Nothing
-
-needsCompilationRule :: Rules ()
-needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do
-  -- It's important to use stale data here to avoid wasted work.
-  -- if NeedsCompilation fails for a module M its result will be  under-approximated
-  -- to False in its dependencies. However, if M actually used TH, this will
-  -- cause a re-evaluation of GetModIface for all dependencies
-  -- (since we don't need to generate object code anymore).
-  -- Once M is fixed we will discover that we actually needed all the object code
-  -- that we just threw away, and thus have to recompile all dependencies once
-  -- again, this time keeping the object code.
-  (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
-  -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell
-  res <-
-    if uses_th_qq ms
-    then pure True
-    else do
-      graph <- useNoFile GetModuleGraph
-      case graph of
-          -- Treat as False if some reverse dependency header fails to parse
-          Nothing -> pure False
-          Just depinfo -> case immediateReverseDependencies file depinfo of
-            -- If we fail to get immediate reverse dependencies, fail with an error message
-            Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file
-            Just revdeps -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps
-
-  pure (Just $ BS.pack $ show $ hash res, ([], Just res))
-  where
-    uses_th_qq (ms_hspp_opts -> dflags) =
-      xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
-
--- | Tracks which linkables are current, so we don't need to unload them
-newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
-instance IsIdeGlobal CompiledLinkables
-
--- | A rule that wires per-file rules together
-mainRule :: Rules ()
-mainRule = do
-    linkables <- liftIO $ newVar emptyModuleEnv
-    addIdeGlobal $ CompiledLinkables linkables
-    getParsedModuleRule
-    getLocatedImportsRule
-    getDependencyInformationRule
-    reportImportCyclesRule
-    getDependenciesRule
-    typeCheckRule
-    getDocMapRule
-    loadGhcSession
-    getModIfaceFromDiskRule
-    getModIfaceRule
-    getModIfaceWithoutLinkableRule
-    getModSummaryRule
-    isHiFileStableRule
-    getModuleGraphRule
-    knownFilesRule
-    getClientSettingsRule
-    getHieAstsRule
-    getBindingsRule
-    needsCompilationRule
-    generateCoreRule
-    getImportMapRule
-
--- | Given the path to a module src file, this rule returns True if the
--- corresponding `.hi` file is stable, that is, if it is newer
---   than the src file, and all its dependencies are stable too.
-data IsHiFileStable = IsHiFileStable
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable IsHiFileStable
-instance NFData   IsHiFileStable
-instance Binary   IsHiFileStable
-
-type instance RuleResult IsHiFileStable = SourceModified
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP                   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE DuplicateRecordFields #-}+#include "ghc-api-version.h"++-- | A Shake implementation of the compiler service, built+--   using the "Shaker" abstraction layer for in-memory use.+--+module Development.IDE.Core.Rules(+    -- * Types+    IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),+    Priority(..), GhcSessionIO(..), GetClientSettings(..),+    -- * Functions+    priorityTypeCheck,+    priorityGenerateCore,+    priorityFilesOfInterest,+    runAction, useE, useNoFileE, usesE,+    toIdeResult,+    defineNoFile,+    defineEarlyCutOffNoFile,+    mainRule,+    getAtPoint,+    getDefinition,+    getTypeDefinition,+    highlightAtPoint,+    getDependencies,+    getParsedModule,+    getClientConfigAction,+    -- * Rules+    CompiledLinkables(..),+    IsHiFileStable(..),+    getParsedModuleRule,+    getLocatedImportsRule,+    getDependencyInformationRule,+    reportImportCyclesRule,+    getDependenciesRule,+    typeCheckRule,+    getDocMapRule,+    loadGhcSession,+    getModIfaceFromDiskRule,+    getModIfaceRule,+    getModIfaceWithoutLinkableRule,+    getModSummaryRule,+    isHiFileStableRule,+    getModuleGraphRule,+    knownFilesRule,+    getClientSettingsRule,+    getHieAstsRule,+    getBindingsRule,+    needsCompilationRule,+    generateCoreRule,+    getImportMapRule+    ) where++import Fingerprint++import Data.Aeson (fromJSON, Result(Success), FromJSON)+import Data.Binary hiding (get, put)+import Data.Default+import Data.Tuple.Extra+import Control.Monad.Extra+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Development.IDE.Core.Compile+import Development.IDE.Core.OfInterest+import Development.IDE.Types.Options+import Development.IDE.Spans.Documentation+import Development.IDE.Spans.LocalBindings+import Development.IDE.Import.DependencyInformation+import Development.IDE.Import.FindImports+import           Development.IDE.Core.FileExists+import           Development.IDE.Core.FileStore        (modificationTime, getFileContents)+import           Development.IDE.Types.Diagnostics as Diag+import Development.IDE.Types.Location+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile)+import Development.IDE.GHC.Util+import Data.Either.Extra+import qualified Development.IDE.Types.Logger as L+import Data.Maybe+import           Data.Foldable+import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict (IntMap)+import Data.List+import qualified Data.Set                                 as Set+import qualified Data.Map as M+import qualified Data.Text                                as T+import qualified Data.Text.Encoding                       as T+import           Development.IDE.GHC.Error+import           Development.Shake                        hiding (Diagnostic)+import Development.IDE.Core.RuleTypes+import qualified Data.ByteString.Char8 as BS+import Development.IDE.Core.PositionMapping+import           Language.Haskell.LSP.Types (DocumentHighlight (..))++import qualified GHC.LanguageExtensions as LangExt+import HscTypes hiding (TargetModule, TargetFile)+import GHC.Generics(Generic)++import qualified Development.IDE.Spans.AtPoint as AtPoint+import Development.IDE.Core.IdeConfiguration+import Development.IDE.Core.Service+import Development.IDE.Core.Shake+import Development.Shake.Classes hiding (get, put)+import Control.Monad.Trans.Except (runExceptT)+import Data.ByteString (ByteString)+import Control.Concurrent.Async (concurrently)+import System.Time.Extra+import Control.Monad.Reader+import System.Directory ( getModificationTime )+import Control.Exception++import Control.Monad.State+import FastString (FastString(uniq))+import qualified HeaderInfo as Hdr+import Data.Time (UTCTime(..))+import Data.Hashable+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HM+import TcRnMonad (tcg_dependent_files)+import Data.IORef+import Control.Concurrent.Extra+import Module++-- | 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+-- warnings while also producing a result.+toIdeResult :: Either [FileDiagnostic] v -> IdeResult v+toIdeResult = either (, Nothing) (([],) . Just)++-- | useE is useful to implement functions that aren’t rules but need shortcircuiting+-- e.g. getDefinition.+useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)+useE k = MaybeT . useWithStaleFast k++useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v+useNoFileE _ide k = fst <$> useE k emptyFilePath++usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]+usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)++defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()+defineNoFile f = define $ \k file -> do+    if file == emptyFilePath then do res <- f k; return ([], Just res) else+        fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"++defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules ()+defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do+    if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else+        fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"+++------------------------------------------------------------+-- Exposed API++-- | Get all transitive file dependencies of a given module.+-- Does not include the file itself.+getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])+getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file++-- | Try to get hover text for the name under point.+getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))+getAtPoint file pos = fmap join $ runMaybeT $ do+  ide <- ask+  opts <- liftIO $ getIdeOptionsIO ide++  (hieAst -> hf, mapping) <- useE GetHieAst file+  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)++  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)+  return $ AtPoint.atPoint opts hf dkMap pos'++-- | Goto Definition.+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)+getDefinition file pos = runMaybeT $ do+    ide <- ask+    opts <- liftIO $ getIdeOptionsIO ide+    (HAR _ hf _ , mapping) <- useE GetHieAst file+    (ImportMap imports, _) <- useE GetImportMap file+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)+    AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos'++getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])+getTypeDefinition file pos = runMaybeT $ do+    ide <- ask+    opts <- liftIO $ getIdeOptionsIO ide+    (hieAst -> hf, mapping) <- useE GetHieAst file+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)+    AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos'++highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])+highlightAtPoint file pos = runMaybeT $ do+    (HAR _ hf rf,mapping) <- useE GetHieAst file+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)+    AtPoint.documentHighlight hf rf pos'++getHieFile+  :: ShakeExtras+  -> NormalizedFilePath -- ^ file we're editing+  -> Module -- ^ module dep we want info for+  -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module+getHieFile ide file mod = do+  TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file+  case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of+    Just NamedModuleDep{nmdFilePath=nfp} -> do+        let modPath = fromNormalizedFilePath nfp+        hieFile <- getHomeHieFile nfp+        return (hieFile, modPath)+    _ -> getPackageHieFile ide mod file++getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile+getHomeHieFile f = do+  ms <- fst . fst <$> useE GetModSummaryWithoutTimestamps f+  let normal_hie_f = toNormalizedFilePath' hie_f+      hie_f = ml_hie_file $ ms_location ms++  mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f)+  srcTimestamp   <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f))+  liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f)+  let isUpToDate+        | Just d <- mbHieTimestamp = d > srcTimestamp+        | otherwise = False++  if isUpToDate+    then do+      ncu <- mkUpdater+      hf <- liftIO $ whenMaybe isUpToDate (loadHieFile ncu hie_f)+      MaybeT $ return hf+    else do+      wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do+        hsc <- hscEnv <$> use_ GhcSession f+        pm <- use_ GetParsedModule f+        (_, mtm)<- typeCheckRuleDefinition hsc pm+        mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk+      _ <- MaybeT $ liftIO $ timeout 1 wait+      ncu <- mkUpdater+      liftIO $ loadHieFile ncu hie_f++getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString+getSourceFileSource nfp = do+    (_, msource) <- getFileContents nfp+    case msource of+        Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)+        Just source -> pure $ T.encodeUtf8 source++getPackageHieFile :: ShakeExtras+                  -> Module             -- ^ Package Module to load .hie file for+                  -> NormalizedFilePath -- ^ Path of home module importing the package module+                  -> MaybeT IdeAction (HieFile, FilePath)+getPackageHieFile ide mod file = do+    pkgState  <- hscEnv . fst <$> useE GhcSession file+    IdeOptions {..} <- liftIO $ getIdeOptionsIO ide+    let unitId = moduleUnitId mod+    case lookupPackageConfig unitId pkgState of+        Just pkgConfig -> do+            -- 'optLocateHieFile' returns Nothing if the file does not exist+            hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod+            path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod+            case (hieFile, path) of+                (Just hiePath, Just modPath) -> do+                    -- deliberately loaded outside the Shake graph+                    -- to avoid dependencies on non-workspace files+                        ncu <- mkUpdater+                        MaybeT $ liftIO $ Just . (, modPath) <$> loadHieFile ncu hiePath+                _ -> MaybeT $ return Nothing+        _ -> MaybeT $ return Nothing++-- | Parse the contents of a daml file.+getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)+getParsedModule file = use GetParsedModule file++------------------------------------------------------------+-- Rules+-- These typically go from key to value and are oracles.++priorityTypeCheck :: Priority+priorityTypeCheck = Priority 0++priorityGenerateCore :: Priority+priorityGenerateCore = Priority (-1)++priorityFilesOfInterest :: Priority+priorityFilesOfInterest = Priority (-2)++-- | IMPORTANT FOR HLINT INTEGRATION:+-- We currently parse the module both with and without Opt_Haddock, and+-- return the one with Haddocks if it -- succeeds. However, this may not work+-- for hlint, and we might need to save the one without haddocks too.+-- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197+-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490+getParsedModuleRule :: Rules ()+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do+    (ms, _) <- use_ GetModSummary file+    sess <- use_ GhcSession file+    let hsc = hscEnv sess+    opt <- getIdeOptions++    let dflags    = ms_hspp_opts ms+        mainParse = getParsedModuleDefinition hsc opt file ms++    -- Parse again (if necessary) to capture Haddock parse errors+    res@(_, (_,pmod)) <- if gopt Opt_Haddock dflags+        then+            liftIO mainParse+        else do+            let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)++            -- parse twice, with and without Haddocks, concurrently+            -- we cannot ignore Haddock parse errors because files of+            -- non-interest are always parsed with Haddocks+            -- If we can parse Haddocks, might as well use them+            --+            -- HLINT INTEGRATION: might need to save the other parsed module too+            ((fp,(diags,res)),(fph,(diagsh,resh))) <- liftIO $ concurrently mainParse haddockParse++            -- Merge haddock and regular diagnostics so we can always report haddock+            -- parse errors+            let diagsM = mergeParseErrorsHaddock diags diagsh+            case resh of+              Just _+                | HaddockParse <- optHaddockParse opt+                -> pure (fph, (diagsM, resh))+              -- If we fail to parse haddocks, report the haddock diagnostics as well and+              -- return the non-haddock parse.+              -- This seems to be the correct behaviour because the Haddock flag is added+              -- by us and not the user, so our IDE shouldn't stop working because of it.+              _ -> pure (fp, (diagsM, res))+    -- Add dependencies on included files+    _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod)+    pure res++withOptHaddock :: ModSummary -> ModSummary+withOptHaddock ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) Opt_Haddock}+++-- | Given some normal parse errors (first) and some from Haddock (second), merge them.+--   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings.+mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]+mergeParseErrorsHaddock normal haddock = normal +++    [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c})+    | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations]+  where+    locations = Set.fromList $ map (Diag._range . thd3) normal++    fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x+                 | otherwise = "Haddock: " <> x++getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))+getParsedModuleDefinition packageState opt file ms = do+    let fp = fromNormalizedFilePath file+    (diag, res) <- parseModule opt packageState fp ms+    case res of+        Nothing -> pure (Nothing, (diag, Nothing))+        Just modu -> do+            mbFingerprint <- traverse (fmap fingerprintToBS . fingerprintFromStringBuffer) (ms_hspp_buf ms)+            pure (mbFingerprint, (diag, Just modu))++getLocatedImportsRule :: Rules ()+getLocatedImportsRule =+    define $ \GetLocatedImports file -> do+        (ms,_) <- use_ GetModSummaryWithoutTimestamps file+        targets <- useNoFile_ GetKnownTargets+        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+        let import_dirs = deps env_eq+        let dflags = hsc_dflags env+            isImplicitCradle = isNothing $ envImportPaths env_eq+        dflags <- return $ if isImplicitCradle+                    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+        (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do+            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource+            case diagOrImp of+                Left diags -> pure (diags, Left (modName, Nothing))+                Right (FileImport path) -> pure ([], Left (modName, Just path))+                Right (PackageImport pkgId) -> liftIO $ do+                    diagsOrPkgDeps <- computePackageDeps env pkgId+                    case diagsOrPkgDeps of+                        Left diags -> pure (diags, Right Nothing)+                        Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)+        let (moduleImports, pkgImports) = partitionEithers imports'+        case sequence pkgImports of+            Nothing -> pure (concat diags, Nothing)+            Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))++type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a++execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)+execRawDepM act =+    execStateT act+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty+        , IntMap.empty+        )++-- | Given a target file path, construct the raw dependency results by following+-- imports recursively.+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation+rawDependencyInformation fs = do+    (rdi, ss) <- execRawDepM (mapM_ go fs)+    let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss+    return (rdi { rawBootMap = bm })+  where+    go :: NormalizedFilePath -- ^ Current module being processed+       -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId+    go f = do+      -- First check to see if we have already processed the FilePath+      -- If we have, just return its Id but don't update any of the state.+      -- Otherwise, we need to process its imports.+      checkAlreadyProcessed f $ do+          msum <- lift $ fmap fst <$> use GetModSummaryWithoutTimestamps f+          let al =  modSummaryToArtifactsLocation f msum+          -- Get a fresh FilePathId for the new file+          fId <- getFreshFid al+          -- Adding an edge to the bootmap so we can make sure to+          -- insert boot nodes before the real files.+          addBootMap al fId+          -- Try to parse the imports of the file+          importsOrErr <- lift $ use GetLocatedImports f+          case importsOrErr of+            Nothing -> do+            -- File doesn't parse so add the module as a failure into the+            -- dependency information, continue processing the other+            -- elements in the queue+              modifyRawDepInfo (insertImport fId (Left ModuleParseError))+              return fId+            Just (modImports, pkgImports) -> do+              -- Get NFPs of the imports which have corresponding files+              -- Imports either come locally from a file or from a package.+              let (no_file, with_file) = splitImports modImports+                  (mns, ls) = unzip with_file+              -- Recursively process all the imports we just learnt about+              -- and get back a list of their FilePathIds+              fids <- mapM (go . artifactFilePath) ls+              -- Associate together the ModuleName with the FilePathId+              let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)+              -- Insert into the map the information about this modules+              -- imports.+              modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)+              return fId+++    checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId+    checkAlreadyProcessed nfp k = do+      (rawDepInfo, _) <- get+      maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)++    modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()+    modifyRawDepInfo f = modify (first f)++    addBootMap ::  ArtifactsLocation -> FilePathId -> RawDepM ()+    addBootMap al fId =+      modify (\(rd, ss) -> (rd, if isBootLocation al+                                  then IntMap.insert (getFilePathId fId) al ss+                                  else ss))++    getFreshFid :: ArtifactsLocation -> RawDepM FilePathId+    getFreshFid al = do+      (rawDepInfo, ss) <- get+      let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)+      -- Insert the File into the bootmap if it's a boot module+      let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }+      put (rawDepInfo', ss)+      return fId++    -- Split in (package imports, local imports)+    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]+                 -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])+    splitImports = foldr splitImportsLoop ([],[])++    splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)+    splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)++    updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =+      if not artifactIsSource+        then+          let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath)+          in case msource_mod_id of+               Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm+               Nothing -> bm+        else bm++    dropBootSuffix :: FilePath -> FilePath+    dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src++getDependencyInformationRule :: Rules ()+getDependencyInformationRule =+    define $ \GetDependencyInformation file -> do+       rawDepInfo <- rawDependencyInformation [file]+       pure ([], Just $ processDependencyInformation rawDepInfo)++reportImportCyclesRule :: Rules ()+reportImportCyclesRule =+    define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do+        DependencyInformation{..} <- use_ GetDependencyInformation file+        let fileId = pathToId depPathIdMap file+        case IntMap.lookup (getFilePathId fileId) depErrorNodes of+            Nothing -> pure []+            Just errs -> do+                let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)+                -- Convert cycles of files into cycles of module names+                forM cycles $ \(imp, files) -> do+                    modNames <- forM files $ \fileId -> do+                        let file = idToPath depPathIdMap fileId+                        getModuleName file+                    pure $ toDiag imp $ sort modNames+    where cycleErrorInFile f (PartOfCycle imp fs)+            | f `elem` fs = Just (imp, fs)+          cycleErrorInFile _ _ = Nothing+          toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic+            { _range = rng+            , _severity = Just DsError+            , _source = Just "Import cycle detection"+            , _message = "Cyclic module dependency between " <> showCycle mods+            , _code = Nothing+            , _relatedInformation = Nothing+            , _tags = Nothing+            }+            where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)+                  fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)+          getModuleName file = do+           ms <- fst <$> use_ GetModSummaryWithoutTimestamps file+           pure (moduleNameString . moduleName . ms_mod $ ms)+          showCycle mods  = T.intercalate ", " (map T.pack mods)++-- returns all transitive dependencies in topological order.+-- NOTE: result does not include the argument file.+getDependenciesRule :: Rules ()+getDependenciesRule =+    defineEarlyCutoff $ \GetDependencies file -> do+        depInfo <- use_ GetDependencyInformation file+        let allFiles = reachableModules depInfo+        _ <- uses_ ReportImportCycles allFiles+        opts <- getIdeOptions+        let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts+        return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))++getHieAstsRule :: Rules ()+getHieAstsRule =+    define $ \GetHieAst f -> do+      tmr <- use_ TypeCheck f+      hsc <- hscEnv <$> use_ GhcSession f+      getHieAstRuleDefinition f hsc tmr++getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)+getHieAstRuleDefinition f hsc tmr = do+  (diags, masts) <- liftIO $ generateHieAsts hsc tmr++  isFoi <- use_ IsFileOfInterest f+  diagsWrite <- case isFoi of+    IsFOI Modified -> pure []+    _ | Just asts <- masts -> do+          source <- getSourceFileSource f+          liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source+    _ -> pure []++  let refmap = generateReferencesMap . getAsts <$> masts+  pure (diags <> diagsWrite, HAR (ms_mod  $ tmrModSummary tmr) <$> masts <*> refmap)++getImportMapRule :: Rules()+getImportMapRule = define $ \GetImportMap f -> do+  im <- use GetLocatedImports f+  let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports+  pure ([], ImportMap . mkImports <$> im)++getBindingsRule :: Rules ()+getBindingsRule =+  define $ \GetBindings f -> do+    har <- use_ GetHieAst f+    pure ([], Just $ bindings $ refMap har)++getDocMapRule :: Rules ()+getDocMapRule =+    define $ \GetDocMap file -> do+      -- Stale data for the scenario where a broken module has previously typechecked+      -- but we never generated a DocMap for it+      (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file+      (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file+      (refMap -> rf, _)         <- useWithStale_ GetHieAst file++-- When possible, rely on the haddocks embedded in our interface files+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'+#if !defined(GHC_LIB)+      let parsedDeps = []+#else+      deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file+      let tdeps = transitiveModuleDeps deps+      parsedDeps <- uses_ GetParsedModule tdeps+#endif++      dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc+      return ([],Just dkMap)++-- Typechecks a module.+typeCheckRule :: Rules ()+typeCheckRule = define $ \TypeCheck file -> do+    pm <- use_ GetParsedModule file+    hsc  <- hscEnv <$> use_ GhcSessionDeps file+    typeCheckRuleDefinition hsc pm++knownFilesRule :: Rules ()+knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do+  alwaysRerun+  fs <- knownTargets+  pure (BS.pack (show $ hash fs), unhashed fs)++getModuleGraphRule :: Rules ()+getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do+  fs <- toKnownFiles <$> useNoFile_ GetKnownTargets+  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)+  pure $ processDependencyInformation rawDepInfo++-- This is factored out so it can be directly called from the GetModIface+-- rule. Directly calling this rule means that on the initial load we can+-- garbage collect all the intermediate typechecked modules rather than+-- retain the information forever in the shake graph.+typeCheckRuleDefinition+    :: HscEnv+    -> ParsedModule+    -> Action (IdeResult TcModuleResult)+typeCheckRuleDefinition hsc pm = do+  setPriority priorityTypeCheck+  IdeOptions { optDefer = defer } <- getIdeOptions++  linkables_to_keep <- currentLinkables++  addUsageDependencies $ liftIO $+    typecheckModule defer hsc linkables_to_keep pm+  where+    addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)+    addUsageDependencies a = do+      r@(_, mtc) <- a+      forM_ mtc $ \tc -> do+        used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc+        void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)+      return r++-- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload.+-- Doesn't actually contain the code, since we don't need it to unload+currentLinkables :: Action [Linkable]+currentLinkables = do+    compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction+    hm <- liftIO $ readVar compiledLinkables+    pure $ map go $ moduleEnvToList hm+  where+    go (mod, time) = LM time mod []++loadGhcSession :: Rules ()+loadGhcSession = do+    -- This function should always be rerun because it tracks changes+    -- to the version of the collection of HscEnv's.+    defineEarlyCutOffNoFile $ \GhcSessionIO -> do+        alwaysRerun+        opts <- getIdeOptions+        res <- optGhcSession opts++        let fingerprint = hash (sessionVersion res)+        return (BS.pack (show fingerprint), res)++    defineEarlyCutoff $ \GhcSession file -> do+        IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO+        (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file++        -- add the deps to the Shake graph+        let addDependency fp = do+                let nfp = toNormalizedFilePath' fp+                itExists <- getFileExists nfp+                when itExists $ void $ use_ GetModificationTime nfp+        mapM_ addDependency deps++        opts <- getIdeOptions+        let cutoffHash =+              case optShakeFiles opts of+                -- optShakeFiles is only set in the DAML case.+                -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915+                Just {} -> ""+                -- Hash the HscEnvEq returned so cutoff if it didn't change+                -- from last time+                Nothing -> BS.pack (show (hash (snd val)))+        return (Just cutoffHash, val)++    define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file++ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)+ghcSessionDepsDefinition file = do+        env <- use_ GhcSession file+        let hsc = hscEnv env+        (ms,_) <- use_ GetModSummaryWithoutTimestamps file+        deps <- use_ GetDependencies file+        let tdeps = transitiveModuleDeps deps+            uses_th_qq =+              xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags+            dflags = ms_hspp_opts ms+        ifaces <- if uses_th_qq+                  then uses_ GetModIface tdeps+                  else uses_ GetModIfaceWithoutLinkable tdeps++        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.+        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.+        -- Long-term we might just want to change the order returned by GetDependencies+        let inLoadOrder = reverse (map hirHomeMod ifaces)++        session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc++        res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' []+        return ([], Just res)++getModIfaceFromDiskRule :: Rules ()+getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do+  (ms,_) <- use_ GetModSummary f+  (diags_session, mb_session) <- ghcSessionDepsDefinition f+  case mb_session of+      Nothing -> return (Nothing, (diags_session, Nothing))+      Just session -> do+        sourceModified <- use_ IsHiFileStable f+        linkableType <- getLinkableType f+        r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)+        case r of+            (diags, Just x) -> do+                let fp = Just (hiFileFingerPrint x)+                return (fp, (diags <> diags_session, Just x))+            (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))++isHiFileStableRule :: Rules ()+isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do+    (ms,_) <- use_ GetModSummaryWithoutTimestamps f+    let hiFile = toNormalizedFilePath'+                $ ml_hi_file $ ms_location ms+    mbHiVersion <- use  GetModificationTime_{missingFileDiagnostics=False} hiFile+    modVersion  <- use_ GetModificationTime f+    sourceModified <- case mbHiVersion of+        Nothing -> pure SourceModified+        Just x ->+            if modificationTime x < modificationTime modVersion+                then pure SourceModified+                else do+                    (fileImports, _) <- use_ GetLocatedImports f+                    let imports = fmap artifactFilePath . snd <$> fileImports+                    deps <- uses_ IsHiFileStable (catMaybes imports)+                    pure $ if all (== SourceUnmodifiedAndStable) deps+                           then SourceUnmodifiedAndStable+                           else SourceUnmodified+    return (Just (BS.pack $ show sourceModified), ([], Just sourceModified))++getModSummaryRule :: Rules ()+getModSummaryRule = do+    defineEarlyCutoff $ \GetModSummary f -> do+        session <- hscEnv <$> use_ GhcSession f+        let dflags = hsc_dflags session+        (modTime, mFileContent) <- getFileContents f+        let fp = fromNormalizedFilePath f+        modS <- liftIO $ runExceptT $+                getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)+        case modS of+            Right res@(ms,_) -> do+                let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime)+                return ( Just (BS.pack $ show fingerPrint) , ([], Just res))+            Left diags -> return (Nothing, (diags, Nothing))++    defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do+        ms <- use GetModSummary f+        case ms of+            Just res@(msWithTimestamps,_) -> do+                let ms = msWithTimestamps {+                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",+                    ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"+                    }+                dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f+                let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms)+                return (Just fp, ([], Just res))+            Nothing -> return (Nothing, ([], Nothing))+    where+        -- Compute a fingerprint from the contents of `ModSummary`,+        -- eliding the timestamps and other non relevant fields.+        computeFingerprint f sb dflags ModSummary{..} =+            let fingerPrint =+                    ( moduleNameString (moduleName ms_mod)+                    , ms_hspp_file+                    , map unLoc opts+                    , ml_hs_file ms_location+                    , fingerPrintImports ms_srcimps+                    , fingerPrintImports ms_textual_imps+                    )+                fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))+                opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f)+            in fingerPrint++        hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)+++generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts)+generateCore runSimplifier file = do+    packageState <- hscEnv <$> use_ GhcSessionDeps file+    tm <- use_ TypeCheck file+    setPriority priorityGenerateCore+    liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)++generateCoreRule :: Rules ()+generateCoreRule =+    define $ \GenerateCore -> generateCore (RunSimplifier True)++getModIfaceRule :: Rules ()+getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do+#if !defined(GHC_LIB)+  fileOfInterest <- use_ IsFileOfInterest f+  res@(_,(_,mhmi)) <- case fileOfInterest of+    IsFOI status -> do+      -- Never load from disk for files of interest+      tmr <- use_ TypeCheck f+      linkableType <- getLinkableType f+      hsc <- hscEnv <$> use_ GhcSessionDeps f+      let compile = fmap ([],) $ use GenerateCore f+      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr+      let fp = hiFileFingerPrint <$> hiFile+      hiDiags <- case hiFile of+        Just hiFile+          | OnDisk <- status+          , not (tmrDeferedError tmr) -> liftIO $ writeHiFile hsc hiFile+        _ -> pure []+      return (fp, (diags++hiDiags, hiFile))+    NotFOI -> do+      hiFile <- use GetModIfaceFromDisk f+      let fp = hiFileFingerPrint <$> hiFile+      return (fp, ([], hiFile))++  -- Record the linkable so we know not to unload it+  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do+      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction+      liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time+  pure res+#else+    tm <- use_ TypeCheck f+    hsc <- hscEnv <$> use_ GhcSessionDeps f+    (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm+    let fp = hiFileFingerPrint <$> hiFile+    return (fp, (diags, hiFile))+#endif++getModIfaceWithoutLinkableRule :: Rules ()+getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do+  mhfr <- use GetModIface f+  let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr+      msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f+  pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr'))++regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult)+regenerateHiFile sess f ms compNeeded = do+    let hsc = hscEnv sess+    opt <- getIdeOptions++    -- Embed haddocks in the interface file+    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)+    (diags, mb_pm) <- case mb_pm of+        Just _ -> return (diags, mb_pm)+        Nothing -> do+            -- if parsing fails, try parsing again with Haddock turned off+            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f ms+            return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)+    case mb_pm of+        Nothing -> return (diags, Nothing)+        Just pm -> do+            -- Invoke typechecking directly to update it without incurring a dependency+            -- on the parsed module and the typecheck rules+            (diags', mtmr) <- typeCheckRuleDefinition hsc pm+            case mtmr of+              Nothing -> pure (diags', Nothing)+              Just tmr -> do++                -- compile writes .o file+                let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr++                -- Bang pattern is important to avoid leaking 'tmr'+                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr++                -- Write hi file+                hiDiags <- case res of+                  Just hiFile+                    | not $ tmrDeferedError tmr ->+                      liftIO $ writeHiFile hsc hiFile+                  _ -> pure []++                -- Write hie file+                (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr+                source <- getSourceFileSource f+                wDiags <- forM masts $ \asts ->+                  liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source++                return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res)+++type CompileMod m = m (IdeResult ModGuts)++-- | HscEnv should have deps included already+compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)+compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do+  res <- mkHiFileResultNoCompile hsc tmr+  pure ([], Just $! res)+compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do+  (diags, mguts) <- getGuts+  case mguts of+    Nothing -> pure (diags, Nothing)+    Just guts -> do+      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType+      pure (diags++diags', res)++getClientSettingsRule :: Rules ()+getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do+  alwaysRerun+  settings <- clientSettings <$> getIdeConfiguration+  return (BS.pack . show . hash $ settings, settings)++-- | Returns the client configurarion stored in the IdeState.+-- You can use this function to access it from shake Rules+getClientConfigAction :: (Default a, FromJSON a) => Action a+getClientConfigAction = do+  mbVal <- unhashed <$> useNoFile_ GetClientSettings+  case fromJSON <$> mbVal of+    Just (Success c) -> return c+    _ -> return def++-- | For now we always use bytecode+getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)+getLinkableType f = do+  needsComp <- use_ NeedsCompilation f+  pure $ if needsComp then Just BCOLinkable else Nothing++needsCompilationRule :: Rules ()+needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do+  -- It's important to use stale data here to avoid wasted work.+  -- if NeedsCompilation fails for a module M its result will be  under-approximated+  -- to False in its dependencies. However, if M actually used TH, this will+  -- cause a re-evaluation of GetModIface for all dependencies+  -- (since we don't need to generate object code anymore).+  -- Once M is fixed we will discover that we actually needed all the object code+  -- that we just threw away, and thus have to recompile all dependencies once+  -- again, this time keeping the object code.+  (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file+  -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell+  res <-+    if uses_th_qq ms+    then pure True+    else do+      graph <- useNoFile GetModuleGraph+      case graph of+          -- Treat as False if some reverse dependency header fails to parse+          Nothing -> pure False+          Just depinfo -> case immediateReverseDependencies file depinfo of+            -- If we fail to get immediate reverse dependencies, fail with an error message+            Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file+            Just revdeps -> anyM (fmap (fromMaybe False) . use NeedsCompilation) revdeps++  pure (Just $ BS.pack $ show $ hash res, ([], Just res))+  where+    uses_th_qq (ms_hspp_opts -> dflags) =+      xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags++-- | Tracks which linkables are current, so we don't need to unload them+newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }+instance IsIdeGlobal CompiledLinkables++-- | A rule that wires per-file rules together+mainRule :: Rules ()+mainRule = do+    linkables <- liftIO $ newVar emptyModuleEnv+    addIdeGlobal $ CompiledLinkables linkables+    getParsedModuleRule+    getLocatedImportsRule+    getDependencyInformationRule+    reportImportCyclesRule+    getDependenciesRule+    typeCheckRule+    getDocMapRule+    loadGhcSession+    getModIfaceFromDiskRule+    getModIfaceRule+    getModIfaceWithoutLinkableRule+    getModSummaryRule+    isHiFileStableRule+    getModuleGraphRule+    knownFilesRule+    getClientSettingsRule+    getHieAstsRule+    getBindingsRule+    needsCompilationRule+    generateCoreRule+    getImportMapRule++-- | Given the path to a module src file, this rule returns True if the+-- corresponding `.hi` file is stable, that is, if it is newer+--   than the src file, and all its dependencies are stable too.+data IsHiFileStable = IsHiFileStable+    deriving (Eq, Show, Typeable, Generic)+instance Hashable IsHiFileStable+instance NFData   IsHiFileStable+instance Binary   IsHiFileStable++type instance RuleResult IsHiFileStable = SourceModified
src/Development/IDE/Core/Service.hs view
@@ -1,87 +1,87 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes #-}
-
--- | A Shake implementation of the compiler service, built
---   using the "Shaker" abstraction layer for in-memory use.
---
-module Development.IDE.Core.Service(
-    getIdeOptions, getIdeOptionsIO,
-    IdeState, initialise, shutdown,
-    runAction,
-    writeProfile,
-    getDiagnostics,
-    ideLogger,
-    updatePositionMapping,
-    ) where
-
-import Data.Maybe
-import Development.IDE.Types.Options (IdeOptions(..))
-import Development.IDE.Core.Debouncer
-import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules)
-import           Development.IDE.Core.FileExists (fileExistsRules)
-import           Development.IDE.Core.OfInterest
-import Development.IDE.Types.Logger as Logger
-import           Development.Shake
-import qualified Language.Haskell.LSP.Messages as LSP
-import qualified Language.Haskell.LSP.Types as LSP
-import qualified Language.Haskell.LSP.Types.Capabilities as LSP
-
-import           Development.IDE.Core.Shake
-import Control.Monad
-
-
-
-------------------------------------------------------------
--- Exposed API
-
--- | Initialise the Compiler Service.
-initialise :: LSP.ClientCapabilities
-           -> Rules ()
-           -> IO LSP.LspId
-           -> (LSP.FromServerMessage -> IO ())
-           -> WithProgressFunc
-           -> WithIndefiniteProgressFunc
-           -> Logger
-           -> Debouncer LSP.NormalizedUri
-           -> IdeOptions
-           -> VFSHandle
-           -> IO IdeState
-initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs =
-    shakeOpen
-        getLspId
-        toDiags
-        wProg
-        wIndefProg
-        caps
-        logger
-        debouncer
-        (optShakeProfiling options)
-        (optReportProgress options)
-        (optTesting options)
-        shakeOptions
-          { shakeThreads = optThreads options
-          , shakeFiles   = fromMaybe "/dev/null" (optShakeFiles options)
-          } $ do
-            addIdeGlobal $ GlobalIdeOptions options
-            fileStoreRules vfs
-            ofInterestRules
-            fileExistsRules caps vfs
-            mainRule
-
-writeProfile :: IdeState -> FilePath -> IO ()
-writeProfile = shakeProfile
-
--- | Shutdown the Compiler Service.
-shutdown :: IdeState -> IO ()
-shutdown = shakeShut
-
--- This will return as soon as the result of the action is
--- available.  There might still be other rules running at this point,
--- e.g., the ofInterestRule.
-runAction :: String -> IdeState -> Action a -> IO a
-runAction herald ide act =
-  join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act)
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++-- | A Shake implementation of the compiler service, built+--   using the "Shaker" abstraction layer for in-memory use.+--+module Development.IDE.Core.Service(+    getIdeOptions, getIdeOptionsIO,+    IdeState, initialise, shutdown,+    runAction,+    writeProfile,+    getDiagnostics,+    ideLogger,+    updatePositionMapping,+    ) where++import Data.Maybe+import Development.IDE.Types.Options (IdeOptions(..))+import Development.IDE.Core.Debouncer+import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules)+import           Development.IDE.Core.FileExists (fileExistsRules)+import           Development.IDE.Core.OfInterest+import Development.IDE.Types.Logger as Logger+import           Development.Shake+import qualified Language.Haskell.LSP.Messages as LSP+import qualified Language.Haskell.LSP.Types as LSP+import qualified Language.Haskell.LSP.Types.Capabilities as LSP++import           Development.IDE.Core.Shake+import Control.Monad++++------------------------------------------------------------+-- Exposed API++-- | Initialise the Compiler Service.+initialise :: LSP.ClientCapabilities+           -> Rules ()+           -> IO LSP.LspId+           -> (LSP.FromServerMessage -> IO ())+           -> WithProgressFunc+           -> WithIndefiniteProgressFunc+           -> Logger+           -> Debouncer LSP.NormalizedUri+           -> IdeOptions+           -> VFSHandle+           -> IO IdeState+initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs =+    shakeOpen+        getLspId+        toDiags+        wProg+        wIndefProg+        caps+        logger+        debouncer+        (optShakeProfiling options)+        (optReportProgress options)+        (optTesting options)+        shakeOptions+          { shakeThreads = optThreads options+          , shakeFiles   = fromMaybe "/dev/null" (optShakeFiles options)+          } $ do+            addIdeGlobal $ GlobalIdeOptions options+            fileStoreRules vfs+            ofInterestRules+            fileExistsRules caps vfs+            mainRule++writeProfile :: IdeState -> FilePath -> IO ()+writeProfile = shakeProfile++-- | Shutdown the Compiler Service.+shutdown :: IdeState -> IO ()+shutdown = shakeShut++-- This will return as soon as the result of the action is+-- available.  There might still be other rules running at this point,+-- e.g., the ofInterestRule.+runAction :: String -> IdeState -> Action a -> IO a+runAction herald ide act =+  join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act)
src/Development/IDE/Core/Shake.hs view
@@ -1,1109 +1,1045 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE ExistentialQuantification  #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecursiveDo #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ConstraintKinds            #-}
-
--- | A Shake implementation of the compiler service.
---
---   There are two primary locations where data lives, and both of
---   these contain much the same data:
---
--- * The Shake database (inside 'shakeDb') stores a map of shake keys
---   to shake values. In our case, these are all of type 'Q' to 'A'.
---   During a single run all the values in the Shake database are consistent
---   so are used in conjunction with each other, e.g. in 'uses'.
---
--- * The 'Values' type stores a map of keys to values. These values are
---   always stored as real Haskell values, whereas Shake serialises all 'A' values
---   between runs. To deserialise a Shake value, we just consult Values.
-module Development.IDE.Core.Shake(
-    IdeState, shakeExtras,
-    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
-    KnownTargets, Target(..), toKnownFiles,
-    IdeRule, IdeResult,
-    GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),
-    shakeOpen, shakeShut,
-    shakeRestart,
-    shakeEnqueue,
-    shakeProfile,
-    use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
-    FastResult(..),
-    use_, useNoFile_, uses_,
-    useWithStale, usesWithStale,
-    useWithStale_, usesWithStale_,
-    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
-    getDiagnostics,
-    getHiddenDiagnostics,
-    IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
-    getIdeGlobalExtras,
-    getIdeOptions,
-    getIdeOptionsIO,
-    GlobalIdeOptions(..),
-    garbageCollect,
-    knownTargets,
-    setPriority,
-    sendEvent,
-    ideLogger,
-    actionLogger,
-    FileVersion(..),
-    Priority(..),
-    updatePositionMapping,
-    deleteValue,
-    OnDiskRule(..),
-    WithProgressFunc, WithIndefiniteProgressFunc,
-    ProgressEvent(..),
-    DelayedAction, mkDelayedAction,
-    IdeAction(..), runIdeAction,
-    mkUpdater,
-    -- Exposed for testing.
-    Q(..),
-    ) where
-
-import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
-import           Development.Shake.Database
-import           Development.Shake.Classes
-import           Development.Shake.Rule
-import qualified Data.HashMap.Strict as HMap
-import qualified Data.Map.Strict as Map
-import qualified Data.ByteString.Char8 as BS
-import           Data.Dynamic
-import           Data.Maybe
-import           Data.Map.Strict (Map)
-import           Data.List.Extra (partition, takeEnd)
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import Data.Tuple.Extra
-import Data.Unique
-import Development.IDE.Core.Debouncer
-import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache )
-import Development.IDE.GHC.Orphans ()
-import Development.IDE.Core.PositionMapping
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Types.Action
-import Development.IDE.Types.Logger hiding (Priority)
-import Development.IDE.Types.KnownTargets
-import Development.IDE.Types.Shake
-import qualified Development.IDE.Types.Logger as Logger
-import Language.Haskell.LSP.Diagnostics
-import qualified Data.SortedList as SL
-import           Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Exports
-import Development.IDE.Types.Location
-import Development.IDE.Types.Options
-import           Control.Concurrent.Async
-import           Control.Concurrent.Extra
-import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, atomically)
-import           Control.DeepSeq
-import           Control.Exception.Extra
-import           System.Time.Extra
-import           Data.Typeable
-import qualified Language.Haskell.LSP.Core as LSP
-import qualified Language.Haskell.LSP.Messages as LSP
-import qualified Language.Haskell.LSP.Types as LSP
-import           System.FilePath hiding (makeRelative)
-import qualified Development.Shake as Shake
-import           Control.Monad.Extra
-import           Data.Time
-import           GHC.Generics
-import           System.IO.Unsafe
-import Language.Haskell.LSP.Types
-import qualified Control.Monad.STM as STM
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Monad.Trans.Maybe
-import Data.Traversable
-import Data.Hashable
-import Development.IDE.Core.Tracing
-
-import Data.IORef
-import NameCache
-import UniqSupply
-import PrelInfo
-import Language.Haskell.LSP.Types.Capabilities
-import OpenTelemetry.Eventlog
-
--- information we stash inside the shakeExtra field
-data ShakeExtras = ShakeExtras
-    {eventer :: LSP.FromServerMessage -> IO ()
-    ,debouncer :: Debouncer NormalizedUri
-    ,logger :: Logger
-    ,globals :: Var (HMap.HashMap TypeRep Dynamic)
-    ,state :: Var Values
-    ,diagnostics :: Var DiagnosticStore
-    ,hiddenDiagnostics :: Var DiagnosticStore
-    ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
-    -- ^ This represents the set of diagnostics that we have published.
-    -- Due to debouncing not every change might get published.
-    ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
-    -- ^ Map from a text document version to a PositionMapping that describes how to map
-    -- positions in a version of that document to positions in the latest version
-    -- First mapping is delta from previous version and second one is an
-    -- accumlation of all previous mappings.
-    ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
-    -- ^ How many rules are running for each file
-    ,progressUpdate :: ProgressEvent -> IO ()
-    -- ^ The generator for unique Lsp identifiers
-    ,ideTesting :: IdeTesting
-    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
-    ,session :: MVar ShakeSession
-    -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
-    ,withProgress           :: WithProgressFunc
-    -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')
-    ,withIndefiniteProgress :: WithIndefiniteProgressFunc
-    -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
-    ,restartShakeSession :: [DelayedAction ()] -> IO ()
-    ,ideNc :: IORef NameCache
-    -- | A mapping of module name to known target (or candidate targets, if missing)
-    ,knownTargetsVar :: Var (Hashed KnownTargets)
-    -- | A mapping of exported identifiers for local modules. Updated on kick
-    ,exportsMap :: Var ExportsMap
-    -- | A work queue for actions added via 'runInShakeSession'
-    ,actionQueue :: ActionQueue
-    ,clientCapabilities :: ClientCapabilities
-    }
-
-type WithProgressFunc = forall a.
-    T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a
-type WithIndefiniteProgressFunc = forall a.
-    T.Text -> LSP.ProgressCancellable -> IO a -> IO a
-
-data ProgressEvent
-    = KickStarted
-    | KickCompleted
-
-getShakeExtras :: Action ShakeExtras
-getShakeExtras = do
-    Just x <- getShakeExtra @ShakeExtras
-    return x
-
-getShakeExtrasRules :: Rules ShakeExtras
-getShakeExtrasRules = do
-    Just x <- getShakeExtraRules @ShakeExtras
-    return x
-
-class Typeable a => IsIdeGlobal a where
-
-addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
-addIdeGlobal x = do
-    extras <- getShakeExtrasRules
-    liftIO $ addIdeGlobalExtras extras x
-
-addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
-addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
-    liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
-        Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
-        Nothing -> return $! HMap.insert ty (toDyn x) mp
-
-
-getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
-getIdeGlobalExtras ShakeExtras{globals} = do
-    let typ = typeRep (Proxy :: Proxy a)
-    x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
-    case x of
-        Just x
-            | Just x <- fromDynamic x -> pure x
-            | 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 = liftIO . getIdeGlobalExtras =<< getShakeExtras
-
-getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
-getIdeGlobalState = getIdeGlobalExtras . shakeExtras
-
-
-newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
-instance IsIdeGlobal GlobalIdeOptions
-
-getIdeOptions :: Action IdeOptions
-getIdeOptions = do
-    GlobalIdeOptions x <- getIdeGlobalAction
-    return x
-
-getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
-getIdeOptionsIO ide = do
-    GlobalIdeOptions x <- getIdeGlobalExtras ide
-    return x
-
--- | Return the most recent, potentially stale, value and a PositionMapping
--- for the version of that value.
-lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
-lastValueIO ShakeExtras{positionMapping} file v = do
-    allMappings <- liftIO $ readVar positionMapping
-    pure $ case v of
-        Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
-        Stale ver v -> Just (v, mappingForVersion allMappings file ver)
-        Failed -> Nothing
-
--- | Return the most recent, potentially stale, value and a PositionMapping
--- for the version of that value.
-lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
-lastValue file v = do
-    s <- getShakeExtras
-    liftIO $ lastValueIO s file v
-
-valueVersion :: Value v -> Maybe TextDocumentVersion
-valueVersion = \case
-    Succeeded ver _ -> Just ver
-    Stale ver _ -> Just ver
-    Failed -> Nothing
-
-mappingForVersion
-    :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
-    -> NormalizedFilePath
-    -> TextDocumentVersion
-    -> PositionMapping
-mappingForVersion allMappings file ver =
-    maybe zeroMapping snd $
-    Map.lookup ver =<<
-    HMap.lookup (filePathToUri' file) allMappings
-
-type IdeRule k v =
-  ( Shake.RuleResult k ~ v
-  , Shake.ShakeValue k
-  , Show v
-  , Typeable v
-  , NFData v
-  )
-
--- | A live Shake session with the ability to enqueue Actions for running.
---   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.
-newtype ShakeSession = ShakeSession
-  { cancelShakeSession :: IO ()
-    -- ^ Closes the Shake session
-  }
-
--- | A Shake database plus persistent store. Can be thought of as storing
---   mappings from @(FilePath, k)@ to @RuleResult k@.
-data IdeState = IdeState
-    {shakeDb         :: ShakeDatabase
-    ,shakeSession    :: MVar ShakeSession
-    ,shakeClose      :: IO ()
-    ,shakeExtras     :: ShakeExtras
-    ,shakeProfileDir :: Maybe FilePath
-    ,stopProgressReporting :: IO ()
-    }
-
-
-
--- This is debugging code that generates a series of profiles, if the Boolean is true
-shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath)
-shakeDatabaseProfile mbProfileDir shakeDb =
-        for mbProfileDir $ \dir -> do
-                count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
-                let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html"
-                shakeProfileDatabase shakeDb $ dir </> file
-                return (dir </> file)
-
-{-# NOINLINE profileStartTime #-}
-profileStartTime :: String
-profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
-
-{-# NOINLINE profileCounter #-}
-profileCounter :: Var Int
-profileCounter = unsafePerformIO $ newVar 0
-
-setValues :: IdeRule k v
-          => Var Values
-          -> k
-          -> NormalizedFilePath
-          -> Value v
-          -> IO ()
-setValues state key file val = modifyVar_ state $ \vals -> do
-    -- Force to make sure the old HashMap is not retained
-    evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
-
--- | Delete the value stored for a given ide build key
-deleteValue
-  :: (Typeable k, Hashable k, Eq k, Show k)
-  => IdeState
-  -> k
-  -> NormalizedFilePath
-  -> IO ()
-deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->
-    evaluate $ HMap.delete (file, Key key) vals
-
--- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
-getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
-getValues state key file = do
-    vs <- readVar state
-    case HMap.lookup (file, Key key) vs of
-        Nothing -> pure Nothing
-        Just v -> do
-            let r = fmap (fromJust . fromDynamic @v) v
-            -- Force to make sure we do not retain a reference to the HashMap
-            -- and we blow up immediately if the fromJust should fail
-            -- (which would be an internal error).
-            evaluate (r `seqValue` Just r)
-
--- | Get all the files in the project
-knownTargets :: Action (Hashed KnownTargets)
-knownTargets = do
-  ShakeExtras{knownTargetsVar} <- getShakeExtras
-  liftIO $ readVar knownTargetsVar
-
--- | Seq the result stored in the Shake value. This only
--- evaluates the value to WHNF not NF. We take care of the latter
--- elsewhere and doing it twice is expensive.
-seqValue :: Value v -> b -> b
-seqValue v b = case v of
-    Succeeded ver v -> rnf ver `seq` v `seq` b
-    Stale ver v -> rnf ver `seq` v `seq` b
-    Failed -> b
-
--- | Open a 'IdeState', should be shut using 'shakeShut'.
-shakeOpen :: IO LSP.LspId
-          -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
-          -> WithProgressFunc
-          -> WithIndefiniteProgressFunc
-          -> ClientCapabilities
-          -> Logger
-          -> Debouncer NormalizedUri
-          -> Maybe FilePath
-          -> IdeReportProgress
-          -> IdeTesting
-          -> ShakeOptions
-          -> Rules ()
-          -> IO IdeState
-shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer
-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo
-
-    inProgress <- newVar HMap.empty
-    us <- mkSplitUniqSupply 'r'
-    ideNc <- newIORef (initNameCache us knownKeyNames)
-    (shakeExtras, stopProgressReporting) <- do
-        globals <- newVar HMap.empty
-        state <- newVar HMap.empty
-        diagnostics <- newVar mempty
-        hiddenDiagnostics <- newVar mempty
-        publishedDiagnostics <- newVar mempty
-        positionMapping <- newVar HMap.empty
-        knownTargetsVar <- newVar $ hashed HMap.empty
-        let restartShakeSession = shakeRestart ideState
-        let session = shakeSession
-        mostRecentProgressEvent <- newTVarIO KickCompleted
-        let progressUpdate = atomically . writeTVar mostRecentProgressEvent
-        progressAsync <- async $
-            when reportProgress $
-                progressThread mostRecentProgressEvent inProgress
-        exportsMap <- newVar mempty
-
-        actionQueue <- newQueue
-
-        pure (ShakeExtras{..}, cancel progressAsync)
-    (shakeDbM, shakeClose) <-
-        shakeOpenDatabase
-            opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
-            rules
-    shakeDb <- shakeDbM
-    initSession <- newSession shakeExtras shakeDb []
-    shakeSession <- newMVar initSession
-    let ideState = IdeState{..}
-
-    IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras
-    startTelemetry otProfilingEnabled logger $ state shakeExtras
-
-    return ideState
-    where
-        -- The progress thread is a state machine with two states:
-        --   1. Idle
-        --   2. Reporting a kick event
-        -- And two transitions, modelled by 'ProgressEvent':
-        --   1. KickCompleted - transitions from Reporting into Idle
-        --   2. KickStarted - transitions from Idle into Reporting
-        progressThread mostRecentProgressEvent inProgress = progressLoopIdle
-          where
-            progressLoopIdle = do
-                atomically $ do
-                    v <- readTVar mostRecentProgressEvent
-                    case v of
-                        KickCompleted -> STM.retry
-                        KickStarted -> return ()
-                asyncReporter <- async lspShakeProgress
-                progressLoopReporting asyncReporter
-            progressLoopReporting asyncReporter = do
-                atomically $ do
-                    v <- readTVar mostRecentProgressEvent
-                    case v of
-                        KickStarted -> STM.retry
-                        KickCompleted -> return ()
-                cancel asyncReporter
-                progressLoopIdle
-
-            lspShakeProgress = do
-                -- first sleep a bit, so we only show progress messages if it's going to take
-                -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
-                unless testing $ sleep 0.1
-                lspId <- getLspId
-                u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
-                eventer $ LSP.ReqWorkDoneProgressCreate $
-                  LSP.fmServerWorkDoneProgressCreateRequest lspId $
-                    LSP.WorkDoneProgressCreateParams { _token = u }
-                bracket_ (start u) (stop u) (loop u Nothing)
-                where
-                    start id = eventer $ LSP.NotWorkDoneProgressBegin $
-                      LSP.fmServerWorkDoneProgressBeginNotification
-                        LSP.ProgressParams
-                            { _token = id
-                            , _value = WorkDoneProgressBeginParams
-                              { _title = "Processing"
-                              , _cancellable = Nothing
-                              , _message = Nothing
-                              , _percentage = Nothing
-                              }
-                            }
-                    stop id = eventer $ LSP.NotWorkDoneProgressEnd $
-                      LSP.fmServerWorkDoneProgressEndNotification
-                        LSP.ProgressParams
-                            { _token = id
-                            , _value = WorkDoneProgressEndParams
-                              { _message = Nothing
-                              }
-                            }
-                    sample = 0.1
-                    loop id prev = do
-                        sleep sample
-                        current <- readVar inProgress
-                        let done = length $ filter (== 0) $ HMap.elems current
-                        let todo = HMap.size current
-                        let next = Just $ T.pack $ show done <> "/" <> show todo
-                        when (next /= prev) $
-                            eventer $ LSP.NotWorkDoneProgressReport $
-                              LSP.fmServerWorkDoneProgressReportNotification
-                                LSP.ProgressParams
-                                    { _token = id
-                                    , _value = LSP.WorkDoneProgressReportParams
-                                    { _cancellable = Nothing
-                                    , _message = next
-                                    , _percentage = Nothing
-                                    }
-                                    }
-                        loop id next
-
-shakeProfile :: IdeState -> FilePath -> IO ()
-shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
-
-shakeShut :: IdeState -> IO ()
-shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
-    -- Shake gets unhappy if you try to close when there is a running
-    -- request so we first abort that.
-    void $ cancelShakeSession runner
-    shakeClose
-    stopProgressReporting
-
-
--- | This is a variant of withMVar where the first argument is run unmasked and if it throws
--- an exception, the previous value is restored while the second argument is executed masked.
-withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
-withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do
-    a <- takeMVar var
-    b <- restore (unmasked a) `onException` putMVar var a
-    (a', c) <- masked b
-    putMVar var a'
-    pure c
-
-
-mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
-mkDelayedAction = DelayedAction Nothing
-
--- | These actions are run asynchronously after the current action is
--- finished running. For example, to trigger a key build after a rule
--- has already finished as is the case with useWithStaleFast
-delayedAction :: DelayedAction a -> IdeAction (IO a)
-delayedAction a = do
-  extras <- ask
-  liftIO $ shakeEnqueue extras a
-
--- | Restart the current 'ShakeSession' with the given system actions.
---   Any actions running in the current session will be aborted,
---   but actions added via 'shakeEnqueue' will be requeued.
-shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()
-shakeRestart IdeState{..} acts =
-    withMVar'
-        shakeSession
-        (\runner -> do
-              (stopTime,()) <- duration (cancelShakeSession runner)
-              res <- shakeDatabaseProfile shakeProfileDir shakeDb
-              let profile = case res of
-                      Just fp -> ", profile saved at " <> fp
-                      _ -> ""
-              let msg = T.pack $ "Restarting build session (aborting the previous one took "
-                              ++ showDuration stopTime ++ profile ++ ")"
-              logDebug (logger shakeExtras) msg
-              notifyTestingLogMessage shakeExtras msg
-        )
-        -- It is crucial to be masked here, otherwise we can get killed
-        -- between spawning the new thread and updating shakeSession.
-        -- See https://github.com/haskell/ghcide/issues/79
-        (\() -> do
-          (,()) <$> newSession shakeExtras shakeDb acts)
-
-notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
-notifyTestingLogMessage extras msg = do
-    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras
-    let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage
-                                  $ LSP.LogMessageParams LSP.MtLog msg
-    when isTestMode $ eventer extras notif
-
-
--- | Enqueue an action in the existing 'ShakeSession'.
---   Returns a computation to block until the action is run, propagating exceptions.
---   Assumes a 'ShakeSession' is available.
---
---   Appropriate for user actions other than edits.
-shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
-shakeEnqueue ShakeExtras{actionQueue, logger} act = do
-    (b, dai) <- instantiateDelayedAction act
-    atomically $ pushQueue dai actionQueue
-    let wait' b =
-            waitBarrier b `catches`
-              [ Handler(\BlockedIndefinitelyOnMVar ->
-                    fail $ "internal bug: forever blocked on MVar for " <>
-                            actionName act)
-              , Handler (\e@AsyncCancelled -> do
-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
-
-                  atomically $ abortQueue dai actionQueue
-                  throw e)
-              ]
-    return (wait' b >>= either throwIO return)
-
--- | Set up a new 'ShakeSession' with a set of initial actions
---   Will crash if there is an existing 'ShakeSession' running.
-newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession
-newSession extras@ShakeExtras{..} shakeDb acts = do
-    reenqueued <- atomically $ peekInProgress actionQueue
-    let
-        -- A daemon-like action used to inject additional work
-        -- Runs actions from the work queue sequentially
-        pumpActionThread otSpan = do
-            d <- liftIO $ atomically $ popQueue actionQueue
-            void $ parallel [run otSpan d, pumpActionThread otSpan]
-
-        -- TODO figure out how to thread the otSpan into defineEarlyCutoff
-        run _otSpan d  = do
-            start <- liftIO offsetTime
-            getAction d
-            liftIO $ atomically $ doneQueue d actionQueue
-            runTime <- liftIO start
-            let msg = T.pack $ "finish: " ++ actionName d
-                            ++ " (took " ++ showDuration runTime ++ ")"
-            liftIO $ do
-                logPriority logger (actionPriority d) msg
-                notifyTestingLogMessage extras msg
-
-        workRun restore = withSpan "Shake session" $ \otSpan -> do
-          let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
-          res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')
-          let res' = case res of
-                      Left e -> "exception: " <> displayException e
-                      Right _ -> "completed"
-          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"
-          return $ do
-              logDebug logger msg
-              notifyTestingLogMessage extras msg
-
-    -- Do the work in a background thread
-    workThread <- asyncWithUnmask workRun
-
-    -- run the wrap up in a separate thread since it contains interruptible
-    -- commands (and we are not using uninterruptible mask)
-    _ <- async $ join $ wait workThread
-
-    --  Cancelling is required to flush the Shake database when either
-    --  the filesystem or the Ghc configuration have changed
-    let cancelShakeSession :: IO ()
-        cancelShakeSession = cancel workThread
-
-    pure (ShakeSession{..})
-
-instantiateDelayedAction
-    :: DelayedAction a
-    -> IO (Barrier (Either SomeException a), DelayedActionInternal)
-instantiateDelayedAction (DelayedAction _ s p a) = do
-  u <- newUnique
-  b <- newBarrier
-  let a' = do
-        -- work gets reenqueued when the Shake session is restarted
-        -- it can happen that a work item finished just as it was reenqueud
-        -- in that case, skipping the work is fine
-        alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b
-        unless alreadyDone $ do
-          x <- actionCatch @SomeException (Right <$> a) (pure . Left)
-          -- ignore exceptions if the barrier has been filled concurrently
-          liftIO $ void $ try @SomeException $ signalBarrier b x
-      d' = DelayedAction (Just u) s p a'
-  return (b, d')
-
-getDiagnostics :: IdeState -> IO [FileDiagnostic]
-getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
-    val <- readVar diagnostics
-    return $ getAllDiagnostics val
-
-getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
-getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
-    val <- readVar hiddenDiagnostics
-    return $ getAllDiagnostics val
-
--- | Clear the results for all files that do not match the given predicate.
-garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
-garbageCollect keep = do
-    ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
-    liftIO $
-        do newState <- modifyVar state $ \values -> do
-               values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
-               return $! dupe values
-           modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
-           modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
-           modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
-           let versionsForFile =
-                   HMap.fromListWith Set.union $
-                   mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
-                   HMap.toList newState
-           modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
-
--- | Define a new Rule without early cutoff
-define
-    :: IdeRule k v
-    => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
-define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
-
--- | Request a Rule result if available
-use :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (Maybe v)
-use key file = head <$> uses key [file]
-
--- | Request a Rule result, it not available return the last computed result, if any, which may be stale
-useWithStale :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
-useWithStale key file = head <$> usesWithStale key [file]
-
--- | Request a Rule result, it not available return the last computed result which may be stale.
---   Errors out if none available.
-useWithStale_ :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (v, PositionMapping)
-useWithStale_ key file = head <$> usesWithStale_ key [file]
-
--- | Plural version of 'useWithStale_'
-usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]
-usesWithStale_ key files = do
-    res <- usesWithStale key files
-    case sequence res of
-        Nothing -> liftIO $ throwIO $ BadDependency (show key)
-        Just v -> return v
-
-newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
-    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
-
--- | IdeActions are used when we want to return a result immediately, even if it
--- is stale Useful for UI actions like hover, completion where we don't want to
--- block.
-runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
-runIdeAction _herald s i = runReaderT (runIdeActionT i) s
-
-askShake :: IdeAction ShakeExtras
-askShake = ask
-
-mkUpdater :: MaybeT IdeAction NameCacheUpdater
-mkUpdater = do
-  ref <- lift $ ideNc <$> askShake
-  pure $ NCU (upNameCache ref)
-
--- | A (maybe) stale result now, and an up to date one later
-data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }
-
--- | Lookup value in the database and return with the stale value immediately
--- Will queue an action to refresh the value.
--- Might block the first time the rule runs, but never blocks after that.
-useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
-useWithStaleFast key file = stale <$> useWithStaleFast' key file
-
--- | Same as useWithStaleFast but lets you wait for an up to date result
-useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
-useWithStaleFast' key file = do
-  -- This lookup directly looks up the key in the shake database and
-  -- returns the last value that was computed for this key without
-  -- checking freshness.
-
-  -- Async trigger the key to be built anyway because we want to
-  -- keep updating the value in the key.
-  wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file
-
-  s@ShakeExtras{state} <- askShake
-  r <- liftIO $ getValues state key file
-  liftIO $ case r of
-    -- block for the result if we haven't computed before
-    Nothing -> do
-      a <- wait
-      r <- getValues state key file
-      case r of
-        Nothing -> return $ FastResult Nothing (pure a)
-        Just v -> do
-          res <- lastValueIO s file v
-          pure $ FastResult res (pure a)
-    -- Otherwise, use the computed value even if it's out of date.
-    Just v -> do
-      res <- lastValueIO s file v
-      pure $ FastResult res wait
-
-useNoFile :: IdeRule k v => k -> Action (Maybe v)
-useNoFile key = use key emptyFilePath
-
-use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
-use_ key file = head <$> uses_ key [file]
-
-useNoFile_ :: IdeRule k v => k -> Action v
-useNoFile_ key = use_ key emptyFilePath
-
-uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
-uses_ key files = do
-    res <- uses key files
-    case sequence res of
-        Nothing -> liftIO $ throwIO $ BadDependency (show key)
-        Just v -> return v
-
-
--- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
---   which short-circuits the rest of the action
-data BadDependency = BadDependency String deriving Show
-instance Exception BadDependency
-
-isBadDependency :: SomeException -> Bool
-isBadDependency x
-    | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
-    | Just (_ :: BadDependency) <- fromException x = True
-    | otherwise = False
-
-newtype Q k = Q (k, NormalizedFilePath)
-    deriving newtype (Eq, Hashable, NFData)
-
-instance Binary k => Binary (Q k) where
-    put (Q (k, fp)) = put (k, fp)
-    get = do
-        (k, fp) <- get
-        -- The `get` implementation of NormalizedFilePath
-        -- does not handle empty file paths so we
-        -- need to handle this ourselves here.
-        pure (Q (k, toNormalizedFilePath' fp))
-
-instance Show k => Show (Q k) where
-    show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
-
--- | Invariant: the 'v' must be in normal form (fully evaluated).
---   Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
-newtype A v = A (Value v)
-    deriving Show
-
-instance NFData (A v) where rnf (A v) = v `seq` ()
-
--- In the Shake database we only store one type of key/result pairs,
--- namely Q (question) / A (answer).
-type instance RuleResult (Q k) = A (RuleResult k)
-
-
--- | Plural version of 'use'
-uses :: IdeRule k v
-    => k -> [NormalizedFilePath] -> Action [Maybe v]
-uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)
-
--- | Return the last computed result which might be stale.
-usesWithStale :: IdeRule k v
-    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
-usesWithStale key files = do
-    values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
-    zipWithM lastValue files values
-
--- | Define a new Rule with early cutoff
-defineEarlyCutoff
-    :: IdeRule k v
-    => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
-    -> Rules ()
-defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
-    extras@ShakeExtras{state, inProgress} <- getShakeExtras
-    -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
-    (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do
-        val <- case old of
-            Just old | mode == RunDependenciesSame -> do
-                v <- liftIO $ getValues state key file
-                case v of
-                    -- No changes in the dependencies and we have
-                    -- an existing result.
-                    Just v -> return $ Just $ RunResult ChangedNothing old $ A v
-                    _ -> return Nothing
-            _ -> return Nothing
-        case val of
-            Just res -> return res
-            Nothing -> do
-                (bs, (diags, res)) <- actionCatch
-                    (do v <- op key file; liftIO $ evaluate $ force v) $
-                    \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
-                modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
-                (bs, res) <- case res of
-                    Nothing -> do
-                        staleV <- liftIO $ getValues state key file
-                        pure $ case staleV of
-                            Nothing -> (toShakeValue ShakeResult bs, Failed)
-                            Just v -> case v of
-                                Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
-                                Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
-                                Failed -> (toShakeValue ShakeResult bs, Failed)
-                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
-                liftIO $ setValues state key file res
-                updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
-                let eq = case (bs, fmap decodeShakeValue old) of
-                        (ShakeResult a, Just (ShakeResult b)) -> a == b
-                        (ShakeStale a, Just (ShakeStale b)) -> a == b
-                        -- If we do not have a previous result
-                        -- or we got ShakeNoCutoff we always return False.
-                        _ -> False
-                return $ RunResult
-                    (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
-                    (encodeShakeValue bs) $
-                    A res
-  where
-    withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
-    withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
-        -- This functions are deliberately eta-expanded to avoid space leaks.
-        -- Do not remove the eta-expansion without profiling a session with at
-        -- least 1000 modifications.
-        where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x
-
-isSuccess :: RunResult (A v) -> Bool
-isSuccess (RunResult _ _ (A Failed)) = False
-isSuccess _ = True
-
--- | Rule type, input file
-data QDisk k = QDisk k NormalizedFilePath
-  deriving (Eq, Generic)
-
-instance Hashable k => Hashable (QDisk k)
-
-instance NFData k => NFData (QDisk k)
-
-instance Binary k => Binary (QDisk k)
-
-instance Show k => Show (QDisk k) where
-    show (QDisk k file) =
-        show k ++ "; " ++ fromNormalizedFilePath file
-
-type instance RuleResult (QDisk k) = Bool
-
-data OnDiskRule = OnDiskRule
-  { getHash :: Action BS.ByteString
-  -- This is used to figure out if the state on disk corresponds to the state in the Shake
-  -- database and we can therefore avoid rerunning. Often this can just be the file hash but
-  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which
-  -- is more stable than the hash of the interface file.
-  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.
-  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.
-  , runRule :: Action (IdeResult BS.ByteString)
-  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.
-  }
-
--- This is used by the DAML compiler for incremental builds. Right now this is not used by
--- ghcide itself but that might change in the future.
--- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on
--- the internals of this module that we do not want to expose.
-defineOnDisk
-  :: (Shake.ShakeValue k, RuleResult k ~ ())
-  => (k -> NormalizedFilePath -> OnDiskRule)
-  -> Rules ()
-defineOnDisk act = addBuiltinRule noLint noIdentity $
-  \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do
-      extras <- getShakeExtras
-      let OnDiskRule{..} = act key file
-      let validateHash h
-              | BS.null h = Nothing
-              | otherwise = Just h
-      let runAct = actionCatch runRule $
-              \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)
-      case mbOld of
-          Nothing -> do
-              (diags, mbHash) <- runAct
-              updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
-              pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
-          Just old -> do
-              current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
-              if mode == RunDependenciesSame && Just old == current && not (BS.null old)
-                  then
-                    -- None of our dependencies changed, we’ve had a successful run before and
-                    -- the state on disk matches the state in the Shake database.
-                    pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
-                  else do
-                    (diags, mbHash) <- runAct
-                    updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
-                    let change
-                          | mbHash == Just old = ChangedRecomputeSame
-                          | otherwise = ChangedRecomputeDiff
-                    pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
-
-needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
-needOnDisk k file = do
-    successfull <- apply1 (QDisk k file)
-    liftIO $ unless successfull $ throwIO $ BadDependency (show k)
-
-needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
-needOnDisks k files = do
-    successfulls <- apply $ map (QDisk k) files
-    liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
-
-toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
-toShakeValue = maybe ShakeNoCutoff
-
-data ShakeValue
-    = ShakeNoCutoff
-    -- ^ This is what we use when we get Nothing from
-    -- a rule.
-    | ShakeResult !BS.ByteString
-    -- ^ This is used both for `Failed`
-    -- as well as `Succeeded`.
-    | ShakeStale !BS.ByteString
-    deriving (Generic, Show)
-
-instance NFData ShakeValue
-
-encodeShakeValue :: ShakeValue -> BS.ByteString
-encodeShakeValue = \case
-    ShakeNoCutoff -> BS.empty
-    ShakeResult r -> BS.cons 'r' r
-    ShakeStale r -> BS.cons 's' r
-
-decodeShakeValue :: BS.ByteString -> ShakeValue
-decodeShakeValue bs = case BS.uncons bs of
-    Nothing -> ShakeNoCutoff
-    Just (x, xs)
-      | x == 'r' -> ShakeResult xs
-      | x == 's' -> ShakeStale xs
-      | otherwise -> error $ "Failed to parse shake value " <> show bs
-
-
-updateFileDiagnostics :: MonadIO m
-  => NormalizedFilePath
-  -> Key
-  -> ShakeExtras
-  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
-  -> m ()
-updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
-    modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
-    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
-        uri = filePathToUri' fp
-        ver = vfsVersion =<< modTime
-        updateDiagnosticsWithForcing new store = do
-            store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store
-            new' <- evaluate $ getUriDiagnostics uri store'
-            return (store', new')
-    mask_ $ do
-        -- Mask async exceptions to ensure that updated diagnostics are always
-        -- published. Otherwise, we might never publish certain diagnostics if
-        -- an exception strikes between modifyVar but before
-        -- publishDiagnosticsNotification.
-        newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown
-        _ <- modifyVar hiddenDiagnostics $  updateDiagnosticsWithForcing $ map snd currentHidden
-        let uri = filePathToUri' fp
-        let delay = if null newDiags then 0.1 else 0
-        registerEvent debouncer delay uri $ do
-             mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
-                 let lastPublish = HMap.lookupDefault [] uri published
-                 when (lastPublish /= newDiags) $
-                     eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
-                 pure $! HMap.insert uri newDiags published
-
-publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
-publishDiagnosticsNotification uri diags =
-    LSP.NotPublishDiagnostics $
-    LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
-    LSP.PublishDiagnosticsParams uri (List diags)
-
-newtype Priority = Priority Double
-
-setPriority :: Priority -> Action ()
-setPriority (Priority p) = reschedule p
-
-sendEvent :: LSP.FromServerMessage -> Action ()
-sendEvent e = do
-    ShakeExtras{eventer} <- getShakeExtras
-    liftIO $ eventer e
-
-ideLogger :: IdeState -> Logger
-ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
-
-actionLogger :: Action Logger
-actionLogger = do
-    ShakeExtras{logger} <- getShakeExtras
-    return logger
-
-
-getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
-getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
-
-
--- | Sets the diagnostics for a file and compilation step
---   if you want to clear the diagnostics call this with an empty list
-setStageDiagnostics
-    :: NormalizedUri
-    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
-    -> T.Text
-    -> [LSP.Diagnostic]
-    -> DiagnosticStore
-    -> DiagnosticStore
-setStageDiagnostics uri ver stage diags ds = newDiagsStore where
-    -- When 'ver' is a new version, updateDiagnostics throws away diagnostics from all stages
-    -- This interacts bady with early cutoff, so we make sure to preserve diagnostics
-    -- from other stages when calling updateDiagnostics
-    -- But this means that updateDiagnostics cannot be called concurrently
-    -- for different stages anymore
-    updatedDiags = Map.insert (Just stage) (SL.toSortedList diags) oldDiags
-    oldDiags = case HMap.lookup uri ds of
-            Just (StoreItem _ byStage) -> byStage
-            _ -> Map.empty
-    newDiagsStore = updateDiagnostics ds uri ver updatedDiags
-
-
-getAllDiagnostics ::
-    DiagnosticStore ->
-    [FileDiagnostic]
-getAllDiagnostics =
-    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
-
-getUriDiagnostics ::
-    NormalizedUri ->
-    DiagnosticStore ->
-    [LSP.Diagnostic]
-getUriDiagnostics uri ds =
-    maybe [] getDiagnosticsFromStore $
-    HMap.lookup uri ds
-
-filterDiagnostics ::
-    (NormalizedFilePath -> Bool) ->
-    DiagnosticStore ->
-    DiagnosticStore
-filterDiagnostics keep =
-    HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
-
-filterVersionMap
-    :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
-    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
-    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
-filterVersionMap =
-    HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
-
-updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
-updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
-    modifyVar_ positionMapping $ \allMappings -> do
-        let uri = toNormalizedUri _uri
-        let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
-        let (_, updatedMapping) =
-                -- Very important to use mapAccum here so that the tails of
-                -- each mapping can be shared, otherwise quadratic space is
-                -- used which is evident in long running sessions.
-                Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
-                  zeroMapping
-                  (Map.insert _version (shared_change, zeroMapping) mappingForUri)
-        pure $! HMap.insert uri updatedMapping allMappings
-  where
-    shared_change = mkDelta changes
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ConstraintKinds            #-}++-- | A Shake implementation of the compiler service.+--+--   There are two primary locations where data lives, and both of+--   these contain much the same data:+--+-- * The Shake database (inside 'shakeDb') stores a map of shake keys+--   to shake values. In our case, these are all of type 'Q' to 'A'.+--   During a single run all the values in the Shake database are consistent+--   so are used in conjunction with each other, e.g. in 'uses'.+--+-- * The 'Values' type stores a map of keys to values. These values are+--   always stored as real Haskell values, whereas Shake serialises all 'A' values+--   between runs. To deserialise a Shake value, we just consult Values.+module Development.IDE.Core.Shake(+    IdeState, shakeExtras,+    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,+    KnownTargets, Target(..), toKnownFiles,+    IdeRule, IdeResult,+    GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics),+    shakeOpen, shakeShut,+    shakeRestart,+    shakeEnqueue,+    shakeProfile,+    use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,+    FastResult(..),+    use_, useNoFile_, uses_,+    useWithStale, usesWithStale,+    useWithStale_, usesWithStale_,+    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,+    getDiagnostics,+    getHiddenDiagnostics,+    IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,+    getIdeGlobalExtras,+    getIdeOptions,+    getIdeOptionsIO,+    GlobalIdeOptions(..),+    garbageCollect,+    knownTargets,+    setPriority,+    sendEvent,+    ideLogger,+    actionLogger,+    FileVersion(..),+    Priority(..),+    updatePositionMapping,+    deleteValue,+    OnDiskRule(..),+    WithProgressFunc, WithIndefiniteProgressFunc,+    ProgressEvent(..),+    DelayedAction, mkDelayedAction,+    IdeAction(..), runIdeAction,+    mkUpdater,+    -- Exposed for testing.+    Q(..),+    ) where++import           Development.Shake hiding (ShakeValue, doesFileExist, Info)+import           Development.Shake.Database+import           Development.Shake.Classes+import           Development.Shake.Rule+import qualified Data.HashMap.Strict as HMap+import qualified Data.Map.Strict as Map+import qualified Data.ByteString.Char8 as BS+import           Data.Dynamic+import           Data.Maybe+import           Data.Map.Strict (Map)+import           Data.List.Extra (partition, takeEnd)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.Tuple.Extra+import Data.Unique+import Development.IDE.Core.Debouncer+import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache )+import Development.IDE.GHC.Orphans ()+import Development.IDE.Core.PositionMapping+import Development.IDE.Core.RuleTypes+import Development.IDE.Types.Action+import Development.IDE.Types.Logger hiding (Priority)+import Development.IDE.Types.KnownTargets+import Development.IDE.Types.Shake+import qualified Development.IDE.Types.Logger as Logger+import Language.Haskell.LSP.Diagnostics+import qualified Data.SortedList as SL+import           Development.IDE.Types.Diagnostics+import Development.IDE.Types.Exports+import Development.IDE.Types.Location+import Development.IDE.Types.Options+import           Control.Concurrent.Async+import           Control.Concurrent.Extra+import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, atomically)+import           Control.DeepSeq+import           Control.Exception.Extra+import           System.Time.Extra+import           Data.Typeable+import qualified Language.Haskell.LSP.Core as LSP+import qualified Language.Haskell.LSP.Messages as LSP+import qualified Language.Haskell.LSP.Types as LSP+import           System.FilePath hiding (makeRelative)+import qualified Development.Shake as Shake+import           Control.Monad.Extra+import           Data.Time+import           GHC.Generics+import           System.IO.Unsafe+import Language.Haskell.LSP.Types+import qualified Control.Monad.STM as STM+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Trans.Maybe+import Data.Traversable+import Data.Hashable+import Development.IDE.Core.Tracing++import Data.IORef+import NameCache+import UniqSupply+import PrelInfo+import Language.Haskell.LSP.Types.Capabilities+import OpenTelemetry.Eventlog++-- information we stash inside the shakeExtra field+data ShakeExtras = ShakeExtras+    {eventer :: LSP.FromServerMessage -> IO ()+    ,debouncer :: Debouncer NormalizedUri+    ,logger :: Logger+    ,globals :: Var (HMap.HashMap TypeRep Dynamic)+    ,state :: Var Values+    ,diagnostics :: Var DiagnosticStore+    ,hiddenDiagnostics :: Var DiagnosticStore+    ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])+    -- ^ This represents the set of diagnostics that we have published.+    -- Due to debouncing not every change might get published.+    ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))+    -- ^ Map from a text document version to a PositionMapping that describes how to map+    -- positions in a version of that document to positions in the latest version+    -- First mapping is delta from previous version and second one is an+    -- accumlation of all previous mappings.+    ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)+    -- ^ How many rules are running for each file+    ,progressUpdate :: ProgressEvent -> IO ()+    -- ^ The generator for unique Lsp identifiers+    ,ideTesting :: IdeTesting+    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants+    ,session :: MVar ShakeSession+    -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component+    ,withProgress           :: WithProgressFunc+    -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')+    ,withIndefiniteProgress :: WithIndefiniteProgressFunc+    -- ^ Same as 'withProgress', but for processes that do not report the percentage complete+    ,restartShakeSession :: [DelayedAction ()] -> IO ()+    ,ideNc :: IORef NameCache+    -- | A mapping of module name to known target (or candidate targets, if missing)+    ,knownTargetsVar :: Var (Hashed KnownTargets)+    -- | A mapping of exported identifiers for local modules. Updated on kick+    ,exportsMap :: Var ExportsMap+    -- | A work queue for actions added via 'runInShakeSession'+    ,actionQueue :: ActionQueue+    ,clientCapabilities :: ClientCapabilities+    }++type WithProgressFunc = forall a.+    T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a+type WithIndefiniteProgressFunc = forall a.+    T.Text -> LSP.ProgressCancellable -> IO a -> IO a++data ProgressEvent+    = KickStarted+    | KickCompleted++getShakeExtras :: Action ShakeExtras+getShakeExtras = do+    Just x <- getShakeExtra @ShakeExtras+    return x++getShakeExtrasRules :: Rules ShakeExtras+getShakeExtrasRules = do+    Just x <- getShakeExtraRules @ShakeExtras+    return x++class Typeable a => IsIdeGlobal a where++addIdeGlobal :: IsIdeGlobal a => a -> Rules ()+addIdeGlobal x = do+    extras <- getShakeExtrasRules+    liftIO $ addIdeGlobalExtras extras x++addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =+    liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of+        Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty+        Nothing -> return $! HMap.insert ty (toDyn x) mp+++getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a+getIdeGlobalExtras ShakeExtras{globals} = do+    let typ = typeRep (Proxy :: Proxy a)+    x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals+    case x of+        Just x+            | Just x <- fromDynamic x -> pure x+            | 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 = liftIO . getIdeGlobalExtras =<< getShakeExtras++getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a+getIdeGlobalState = getIdeGlobalExtras . shakeExtras+++newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions+instance IsIdeGlobal GlobalIdeOptions++getIdeOptions :: Action IdeOptions+getIdeOptions = do+    GlobalIdeOptions x <- getIdeGlobalAction+    return x++getIdeOptionsIO :: ShakeExtras -> IO IdeOptions+getIdeOptionsIO ide = do+    GlobalIdeOptions x <- getIdeGlobalExtras ide+    return x++-- | Return the most recent, potentially stale, value and a PositionMapping+-- for the version of that value.+lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))+lastValueIO ShakeExtras{positionMapping} file v = do+    allMappings <- liftIO $ readVar positionMapping+    pure $ case v of+        Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)+        Stale ver v -> Just (v, mappingForVersion allMappings file ver)+        Failed -> Nothing++-- | Return the most recent, potentially stale, value and a PositionMapping+-- for the version of that value.+lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))+lastValue file v = do+    s <- getShakeExtras+    liftIO $ lastValueIO s file v++valueVersion :: Value v -> Maybe TextDocumentVersion+valueVersion = \case+    Succeeded ver _ -> Just ver+    Stale ver _ -> Just ver+    Failed -> Nothing++mappingForVersion+    :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))+    -> NormalizedFilePath+    -> TextDocumentVersion+    -> PositionMapping+mappingForVersion allMappings file ver =+    maybe zeroMapping snd $+    Map.lookup ver =<<+    HMap.lookup (filePathToUri' file) allMappings++type IdeRule k v =+  ( Shake.RuleResult k ~ v+  , Shake.ShakeValue k+  , Show v+  , Typeable v+  , NFData v+  )++-- | A live Shake session with the ability to enqueue Actions for running.+--   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.+newtype ShakeSession = ShakeSession+  { cancelShakeSession :: IO ()+    -- ^ Closes the Shake session+  }++-- | A Shake database plus persistent store. Can be thought of as storing+--   mappings from @(FilePath, k)@ to @RuleResult k@.+data IdeState = IdeState+    {shakeDb         :: ShakeDatabase+    ,shakeSession    :: MVar ShakeSession+    ,shakeClose      :: IO ()+    ,shakeExtras     :: ShakeExtras+    ,shakeProfileDir :: Maybe FilePath+    ,stopProgressReporting :: IO ()+    }++++-- This is debugging code that generates a series of profiles, if the Boolean is true+shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath)+shakeDatabaseProfile mbProfileDir shakeDb =+        for mbProfileDir $ \dir -> do+                count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)+                let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html"+                shakeProfileDatabase shakeDb $ dir </> file+                return (dir </> file)++{-# NOINLINE profileStartTime #-}+profileStartTime :: String+profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime++{-# NOINLINE profileCounter #-}+profileCounter :: Var Int+profileCounter = unsafePerformIO $ newVar 0++setValues :: IdeRule k v+          => Var Values+          -> k+          -> NormalizedFilePath+          -> Value v+          -> Vector FileDiagnostic+          -> IO ()+setValues state key file val diags = modifyVar_ state $ \vals -> do+    -- Force to make sure the old HashMap is not retained+    evaluate $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) vals++-- | Delete the value stored for a given ide build key+deleteValue+  :: (Typeable k, Hashable k, Eq k, Show k)+  => IdeState+  -> k+  -> NormalizedFilePath+  -> IO ()+deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->+    evaluate $ HMap.delete (file, Key key) vals++-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.+getValues ::+  forall k v.+  IdeRule k v =>+  Var Values ->+  k ->+  NormalizedFilePath ->+  IO (Maybe (Value v, Vector FileDiagnostic))+getValues state key file = do+    vs <- readVar state+    case HMap.lookup (file, Key key) vs of+        Nothing -> pure Nothing+        Just (ValueWithDiagnostics v diagsV) -> do+            let r = fmap (fromJust . fromDynamic @v) v+            -- Force to make sure we do not retain a reference to the HashMap+            -- and we blow up immediately if the fromJust should fail+            -- (which would be an internal error).+            evaluate (r `seqValue` Just (r, diagsV))++-- | Get all the files in the project+knownTargets :: Action (Hashed KnownTargets)+knownTargets = do+  ShakeExtras{knownTargetsVar} <- getShakeExtras+  liftIO $ readVar knownTargetsVar++-- | Seq the result stored in the Shake value. This only+-- evaluates the value to WHNF not NF. We take care of the latter+-- elsewhere and doing it twice is expensive.+seqValue :: Value v -> b -> b+seqValue v b = case v of+    Succeeded ver v -> rnf ver `seq` v `seq` b+    Stale ver v -> rnf ver `seq` v `seq` b+    Failed -> b++-- | Open a 'IdeState', should be shut using 'shakeShut'.+shakeOpen :: IO LSP.LspId+          -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler+          -> WithProgressFunc+          -> WithIndefiniteProgressFunc+          -> ClientCapabilities+          -> Logger+          -> Debouncer NormalizedUri+          -> Maybe FilePath+          -> IdeReportProgress+          -> IdeTesting+          -> ShakeOptions+          -> Rules ()+          -> IO IdeState+shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo++    inProgress <- newVar HMap.empty+    us <- mkSplitUniqSupply 'r'+    ideNc <- newIORef (initNameCache us knownKeyNames)+    (shakeExtras, stopProgressReporting) <- do+        globals <- newVar HMap.empty+        state <- newVar HMap.empty+        diagnostics <- newVar mempty+        hiddenDiagnostics <- newVar mempty+        publishedDiagnostics <- newVar mempty+        positionMapping <- newVar HMap.empty+        knownTargetsVar <- newVar $ hashed HMap.empty+        let restartShakeSession = shakeRestart ideState+        let session = shakeSession+        mostRecentProgressEvent <- newTVarIO KickCompleted+        let progressUpdate = atomically . writeTVar mostRecentProgressEvent+        progressAsync <- async $+            when reportProgress $+                progressThread mostRecentProgressEvent inProgress+        exportsMap <- newVar mempty++        actionQueue <- newQueue++        pure (ShakeExtras{..}, cancel progressAsync)+    (shakeDbM, shakeClose) <-+        shakeOpenDatabase+            opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }+            rules+    shakeDb <- shakeDbM+    initSession <- newSession shakeExtras shakeDb []+    shakeSession <- newMVar initSession+    let ideState = IdeState{..}++    IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras+    startTelemetry otProfilingEnabled logger $ state shakeExtras++    return ideState+    where+        -- The progress thread is a state machine with two states:+        --   1. Idle+        --   2. Reporting a kick event+        -- And two transitions, modelled by 'ProgressEvent':+        --   1. KickCompleted - transitions from Reporting into Idle+        --   2. KickStarted - transitions from Idle into Reporting+        progressThread mostRecentProgressEvent inProgress = progressLoopIdle+          where+            progressLoopIdle = do+                atomically $ do+                    v <- readTVar mostRecentProgressEvent+                    case v of+                        KickCompleted -> STM.retry+                        KickStarted -> return ()+                asyncReporter <- async lspShakeProgress+                progressLoopReporting asyncReporter+            progressLoopReporting asyncReporter = do+                atomically $ do+                    v <- readTVar mostRecentProgressEvent+                    case v of+                        KickStarted -> STM.retry+                        KickCompleted -> return ()+                cancel asyncReporter+                progressLoopIdle++            lspShakeProgress = do+                -- first sleep a bit, so we only show progress messages if it's going to take+                -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)+                unless testing $ sleep 0.1+                lspId <- getLspId+                u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique+                eventer $ LSP.ReqWorkDoneProgressCreate $+                  LSP.fmServerWorkDoneProgressCreateRequest lspId $+                    LSP.WorkDoneProgressCreateParams { _token = u }+                bracket_ (start u) (stop u) (loop u Nothing)+                where+                    start id = eventer $ LSP.NotWorkDoneProgressBegin $+                      LSP.fmServerWorkDoneProgressBeginNotification+                        LSP.ProgressParams+                            { _token = id+                            , _value = WorkDoneProgressBeginParams+                              { _title = "Processing"+                              , _cancellable = Nothing+                              , _message = Nothing+                              , _percentage = Nothing+                              }+                            }+                    stop id = eventer $ LSP.NotWorkDoneProgressEnd $+                      LSP.fmServerWorkDoneProgressEndNotification+                        LSP.ProgressParams+                            { _token = id+                            , _value = WorkDoneProgressEndParams+                              { _message = Nothing+                              }+                            }+                    sample = 0.1+                    loop id prev = do+                        sleep sample+                        current <- readVar inProgress+                        let done = length $ filter (== 0) $ HMap.elems current+                        let todo = HMap.size current+                        let next = Just $ T.pack $ show done <> "/" <> show todo+                        when (next /= prev) $+                            eventer $ LSP.NotWorkDoneProgressReport $+                              LSP.fmServerWorkDoneProgressReportNotification+                                LSP.ProgressParams+                                    { _token = id+                                    , _value = LSP.WorkDoneProgressReportParams+                                    { _cancellable = Nothing+                                    , _message = next+                                    , _percentage = Nothing+                                    }+                                    }+                        loop id next++shakeProfile :: IdeState -> FilePath -> IO ()+shakeProfile IdeState{..} = shakeProfileDatabase shakeDb++shakeShut :: IdeState -> IO ()+shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do+    -- Shake gets unhappy if you try to close when there is a running+    -- request so we first abort that.+    void $ cancelShakeSession runner+    shakeClose+    stopProgressReporting+++-- | This is a variant of withMVar where the first argument is run unmasked and if it throws+-- an exception, the previous value is restored while the second argument is executed masked.+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c+withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do+    a <- takeMVar var+    b <- restore (unmasked a) `onException` putMVar var a+    (a', c) <- masked b+    putMVar var a'+    pure c+++mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a+mkDelayedAction = DelayedAction Nothing++-- | These actions are run asynchronously after the current action is+-- finished running. For example, to trigger a key build after a rule+-- has already finished as is the case with useWithStaleFast+delayedAction :: DelayedAction a -> IdeAction (IO a)+delayedAction a = do+  extras <- ask+  liftIO $ shakeEnqueue extras a++-- | Restart the current 'ShakeSession' with the given system actions.+--   Any actions running in the current session will be aborted,+--   but actions added via 'shakeEnqueue' will be requeued.+shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()+shakeRestart IdeState{..} acts =+    withMVar'+        shakeSession+        (\runner -> do+              (stopTime,()) <- duration (cancelShakeSession runner)+              res <- shakeDatabaseProfile shakeProfileDir shakeDb+              let profile = case res of+                      Just fp -> ", profile saved at " <> fp+                      _ -> ""+              let msg = T.pack $ "Restarting build session (aborting the previous one took "+                              ++ showDuration stopTime ++ profile ++ ")"+              logDebug (logger shakeExtras) msg+              notifyTestingLogMessage shakeExtras msg+        )+        -- It is crucial to be masked here, otherwise we can get killed+        -- between spawning the new thread and updating shakeSession.+        -- See https://github.com/haskell/ghcide/issues/79+        (\() -> do+          (,()) <$> newSession shakeExtras shakeDb acts)++notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()+notifyTestingLogMessage extras msg = do+    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras+    let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage+                                  $ LSP.LogMessageParams LSP.MtLog msg+    when isTestMode $ eventer extras notif+++-- | Enqueue an action in the existing 'ShakeSession'.+--   Returns a computation to block until the action is run, propagating exceptions.+--   Assumes a 'ShakeSession' is available.+--+--   Appropriate for user actions other than edits.+shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)+shakeEnqueue ShakeExtras{actionQueue, logger} act = do+    (b, dai) <- instantiateDelayedAction act+    atomically $ pushQueue dai actionQueue+    let wait' b =+            waitBarrier b `catches`+              [ Handler(\BlockedIndefinitelyOnMVar ->+                    fail $ "internal bug: forever blocked on MVar for " <>+                            actionName act)+              , Handler (\e@AsyncCancelled -> do+                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"++                  atomically $ abortQueue dai actionQueue+                  throw e)+              ]+    return (wait' b >>= either throwIO return)++-- | Set up a new 'ShakeSession' with a set of initial actions+--   Will crash if there is an existing 'ShakeSession' running.+newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession+newSession extras@ShakeExtras{..} shakeDb acts = do+    reenqueued <- atomically $ peekInProgress actionQueue+    let+        -- A daemon-like action used to inject additional work+        -- Runs actions from the work queue sequentially+        pumpActionThread otSpan = do+            d <- liftIO $ atomically $ popQueue actionQueue+            void $ parallel [run otSpan d, pumpActionThread otSpan]++        -- TODO figure out how to thread the otSpan into defineEarlyCutoff+        run _otSpan d  = do+            start <- liftIO offsetTime+            getAction d+            liftIO $ atomically $ doneQueue d actionQueue+            runTime <- liftIO start+            let msg = T.pack $ "finish: " ++ actionName d+                            ++ " (took " ++ showDuration runTime ++ ")"+            liftIO $ do+                logPriority logger (actionPriority d) msg+                notifyTestingLogMessage extras msg++        workRun restore = withSpan "Shake session" $ \otSpan -> do+          let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)+          res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')+          let res' = case res of+                      Left e -> "exception: " <> displayException e+                      Right _ -> "completed"+          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"+          return $ do+              logDebug logger msg+              notifyTestingLogMessage extras msg++    -- Do the work in a background thread+    workThread <- asyncWithUnmask workRun++    -- run the wrap up in a separate thread since it contains interruptible+    -- commands (and we are not using uninterruptible mask)+    _ <- async $ join $ wait workThread++    --  Cancelling is required to flush the Shake database when either+    --  the filesystem or the Ghc configuration have changed+    let cancelShakeSession :: IO ()+        cancelShakeSession = cancel workThread++    pure (ShakeSession{..})++instantiateDelayedAction+    :: DelayedAction a+    -> IO (Barrier (Either SomeException a), DelayedActionInternal)+instantiateDelayedAction (DelayedAction _ s p a) = do+  u <- newUnique+  b <- newBarrier+  let a' = do+        -- work gets reenqueued when the Shake session is restarted+        -- it can happen that a work item finished just as it was reenqueud+        -- in that case, skipping the work is fine+        alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b+        unless alreadyDone $ do+          x <- actionCatch @SomeException (Right <$> a) (pure . Left)+          -- ignore exceptions if the barrier has been filled concurrently+          liftIO $ void $ try @SomeException $ signalBarrier b x+      d' = DelayedAction (Just u) s p a'+  return (b, d')++getDiagnostics :: IdeState -> IO [FileDiagnostic]+getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do+    val <- readVar diagnostics+    return $ getAllDiagnostics val++getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]+getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do+    val <- readVar hiddenDiagnostics+    return $ getAllDiagnostics val++-- | Clear the results for all files that do not match the given predicate.+garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()+garbageCollect keep = do+    ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras+    liftIO $+        do newState <- modifyVar state $ \values -> do+               values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values+               return $! dupe values+           modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags+           modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags+           modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags+           let versionsForFile =+                   HMap.fromListWith Set.union $+                   mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $+                   HMap.toList newState+           modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings++-- | Define a new Rule without early cutoff+define+    :: IdeRule k v+    => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()+define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v++-- | Request a Rule result if available+use :: IdeRule k v+    => k -> NormalizedFilePath -> Action (Maybe v)+use key file = head <$> uses key [file]++-- | Request a Rule result, it not available return the last computed result, if any, which may be stale+useWithStale :: IdeRule k v+    => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))+useWithStale key file = head <$> usesWithStale key [file]++-- | Request a Rule result, it not available return the last computed result which may be stale.+--   Errors out if none available.+useWithStale_ :: IdeRule k v+    => k -> NormalizedFilePath -> Action (v, PositionMapping)+useWithStale_ key file = head <$> usesWithStale_ key [file]++-- | Plural version of 'useWithStale_'+usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]+usesWithStale_ key files = do+    res <- usesWithStale key files+    case sequence res of+        Nothing -> liftIO $ throwIO $ BadDependency (show key)+        Just v -> return v++newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }+    deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)++-- | IdeActions are used when we want to return a result immediately, even if it+-- is stale Useful for UI actions like hover, completion where we don't want to+-- block.+runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a+runIdeAction _herald s i = runReaderT (runIdeActionT i) s++askShake :: IdeAction ShakeExtras+askShake = ask++mkUpdater :: MaybeT IdeAction NameCacheUpdater+mkUpdater = do+  ref <- lift $ ideNc <$> askShake+  pure $ NCU (upNameCache ref)++-- | A (maybe) stale result now, and an up to date one later+data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }++-- | Lookup value in the database and return with the stale value immediately+-- Will queue an action to refresh the value.+-- Might block the first time the rule runs, but never blocks after that.+useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))+useWithStaleFast key file = stale <$> useWithStaleFast' key file++-- | Same as useWithStaleFast but lets you wait for an up to date result+useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)+useWithStaleFast' key file = do+  -- This lookup directly looks up the key in the shake database and+  -- returns the last value that was computed for this key without+  -- checking freshness.++  -- Async trigger the key to be built anyway because we want to+  -- keep updating the value in the key.+  wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file++  s@ShakeExtras{state} <- askShake+  r <- liftIO $ getValues state key file+  liftIO $ case r of+    -- block for the result if we haven't computed before+    Nothing -> do+      a <- wait+      r <- getValues state key file+      case r of+        Nothing -> return $ FastResult Nothing (pure a)+        Just (v, _) -> do+          res <- lastValueIO s file v+          pure $ FastResult res (pure a)+    -- Otherwise, use the computed value even if it's out of date.+    Just (v, _) -> do+      res <- lastValueIO s file v+      pure $ FastResult res wait++useNoFile :: IdeRule k v => k -> Action (Maybe v)+useNoFile key = use key emptyFilePath++use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v+use_ key file = head <$> uses_ key [file]++useNoFile_ :: IdeRule k v => k -> Action v+useNoFile_ key = use_ key emptyFilePath++uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]+uses_ key files = do+    res <- uses key files+    case sequence res of+        Nothing -> liftIO $ throwIO $ BadDependency (show key)+        Just v -> return v++-- | Plural version of 'use'+uses :: IdeRule k v+    => k -> [NormalizedFilePath] -> Action [Maybe v]+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)++-- | Return the last computed result which might be stale.+usesWithStale :: IdeRule k v+    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]+usesWithStale key files = do+    values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)+    zipWithM lastValue files values++-- | Define a new Rule with early cutoff+defineEarlyCutoff+    :: IdeRule k v+    => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))+    -> Rules ()+defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do+    extras@ShakeExtras{state, inProgress} <- getShakeExtras+    -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key+    (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do+        val <- case old of+            Just old | mode == RunDependenciesSame -> do+                v <- liftIO $ getValues state key file+                case v of+                    -- No changes in the dependencies and we have+                    -- an existing result.+                    Just (v, diags) -> do+                        updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags+                        return $ Just $ RunResult ChangedNothing old $ A v+                    _ -> return Nothing+            _ -> return Nothing+        case val of+            Just res -> return res+            Nothing -> do+                (bs, (diags, res)) <- actionCatch+                    (do v <- op key file; liftIO $ evaluate $ force v) $+                    \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))+                modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file+                (bs, res) <- case res of+                    Nothing -> do+                        staleV <- liftIO $ getValues state key file+                        pure $ case staleV of+                            Nothing -> (toShakeValue ShakeResult bs, Failed)+                            Just v -> case v of+                                (Succeeded ver v, _) ->+                                    (toShakeValue ShakeStale bs, Stale ver v)+                                (Stale ver v, _) ->+                                    (toShakeValue ShakeStale bs, Stale ver v)+                                (Failed, _) ->+                                    (toShakeValue ShakeResult bs, Failed)+                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)+                liftIO $ setValues state key file res (Vector.fromList diags)+                updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags+                let eq = case (bs, fmap decodeShakeValue old) of+                        (ShakeResult a, Just (ShakeResult b)) -> a == b+                        (ShakeStale a, Just (ShakeStale b)) -> a == b+                        -- If we do not have a previous result+                        -- or we got ShakeNoCutoff we always return False.+                        _ -> False+                return $ RunResult+                    (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)+                    (encodeShakeValue bs) $+                    A res+  where+    withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b+    withProgressVar var file = actionBracket (f succ) (const $ f pred) . const+        -- This functions are deliberately eta-expanded to avoid space leaks.+        -- Do not remove the eta-expansion without profiling a session with at+        -- least 1000 modifications.+        where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x++isSuccess :: RunResult (A v) -> Bool+isSuccess (RunResult _ _ (A Failed)) = False+isSuccess _ = True++-- | Rule type, input file+data QDisk k = QDisk k NormalizedFilePath+  deriving (Eq, Generic)++instance Hashable k => Hashable (QDisk k)++instance NFData k => NFData (QDisk k)++instance Binary k => Binary (QDisk k)++instance Show k => Show (QDisk k) where+    show (QDisk k file) =+        show k ++ "; " ++ fromNormalizedFilePath file++type instance RuleResult (QDisk k) = Bool++data OnDiskRule = OnDiskRule+  { getHash :: Action BS.ByteString+  -- This is used to figure out if the state on disk corresponds to the state in the Shake+  -- database and we can therefore avoid rerunning. Often this can just be the file hash but+  -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which+  -- is more stable than the hash of the interface file.+  -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing.+  -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB.+  , runRule :: Action (IdeResult BS.ByteString)+  -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics.+  }++-- This is used by the DAML compiler for incremental builds. Right now this is not used by+-- ghcide itself but that might change in the future.+-- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on+-- the internals of this module that we do not want to expose.+defineOnDisk+  :: (Shake.ShakeValue k, RuleResult k ~ ())+  => (k -> NormalizedFilePath -> OnDiskRule)+  -> Rules ()+defineOnDisk act = addBuiltinRule noLint noIdentity $+  \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do+      extras <- getShakeExtras+      let OnDiskRule{..} = act key file+      let validateHash h+              | BS.null h = Nothing+              | otherwise = Just h+      let runAct = actionCatch runRule $+              \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing)+      case mbOld of+          Nothing -> do+              (diags, mbHash) <- runAct+              updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags+              pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)+          Just old -> do+              current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")+              if mode == RunDependenciesSame && Just old == current && not (BS.null old)+                  then+                    -- None of our dependencies changed, we’ve had a successful run before and+                    -- the state on disk matches the state in the Shake database.+                    pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)+                  else do+                    (diags, mbHash) <- runAct+                    updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags+                    let change+                          | mbHash == Just old = ChangedRecomputeSame+                          | otherwise = ChangedRecomputeDiff+                    pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)++needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()+needOnDisk k file = do+    successfull <- apply1 (QDisk k file)+    liftIO $ unless successfull $ throwIO $ BadDependency (show k)++needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()+needOnDisks k files = do+    successfulls <- apply $ map (QDisk k) files+    liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)++updateFileDiagnostics :: MonadIO m+  => NormalizedFilePath+  -> Key+  -> ShakeExtras+  -> [(ShowDiagnostic,Diagnostic)] -- ^ current results+  -> m ()+updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do+    modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp+    let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current+        uri = filePathToUri' fp+        ver = vfsVersion =<< modTime+        updateDiagnosticsWithForcing new store = do+            store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store+            new' <- evaluate $ getUriDiagnostics uri store'+            return (store', new')+    mask_ $ do+        -- Mask async exceptions to ensure that updated diagnostics are always+        -- published. Otherwise, we might never publish certain diagnostics if+        -- an exception strikes between modifyVar but before+        -- publishDiagnosticsNotification.+        newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown+        _ <- modifyVar hiddenDiagnostics $  updateDiagnosticsWithForcing $ map snd currentHidden+        let uri = filePathToUri' fp+        let delay = if null newDiags then 0.1 else 0+        registerEvent debouncer delay uri $ do+             mask_ $ modifyVar_ publishedDiagnostics $ \published -> do+                 let lastPublish = HMap.lookupDefault [] uri published+                 when (lastPublish /= newDiags) $+                     eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags+                 pure $! HMap.insert uri newDiags published++publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage+publishDiagnosticsNotification uri diags =+    LSP.NotPublishDiagnostics $+    LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $+    LSP.PublishDiagnosticsParams uri (List diags)++newtype Priority = Priority Double++setPriority :: Priority -> Action ()+setPriority (Priority p) = reschedule p++sendEvent :: LSP.FromServerMessage -> Action ()+sendEvent e = do+    ShakeExtras{eventer} <- getShakeExtras+    liftIO $ eventer e++ideLogger :: IdeState -> Logger+ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger++actionLogger :: Action Logger+actionLogger = do+    ShakeExtras{logger} <- getShakeExtras+    return logger+++getDiagnosticsFromStore :: StoreItem -> [Diagnostic]+getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags+++-- | Sets the diagnostics for a file and compilation step+--   if you want to clear the diagnostics call this with an empty list+setStageDiagnostics+    :: NormalizedUri+    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited+    -> T.Text+    -> [LSP.Diagnostic]+    -> DiagnosticStore+    -> DiagnosticStore+setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags+  where+    updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags)++getAllDiagnostics ::+    DiagnosticStore ->+    [FileDiagnostic]+getAllDiagnostics =+    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList++getUriDiagnostics ::+    NormalizedUri ->+    DiagnosticStore ->+    [LSP.Diagnostic]+getUriDiagnostics uri ds =+    maybe [] getDiagnosticsFromStore $+    HMap.lookup uri ds++filterDiagnostics ::+    (NormalizedFilePath -> Bool) ->+    DiagnosticStore ->+    DiagnosticStore+filterDiagnostics keep =+    HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)++filterVersionMap+    :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)+    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)+    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)+filterVersionMap =+    HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep++updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do+    modifyVar_ positionMapping $ \allMappings -> do+        let uri = toNormalizedUri _uri+        let mappingForUri = HMap.lookupDefault Map.empty uri allMappings+        let (_, updatedMapping) =+                -- Very important to use mapAccum here so that the tails of+                -- each mapping can be shared, otherwise quadratic space is+                -- used which is evident in long running sessions.+                Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))+                  zeroMapping+                  (Map.insert _version (shared_change, zeroMapping) mappingForUri)+        pure $! HMap.insert uri updatedMapping allMappings+  where+    shared_change = mkDelta changes
src/Development/IDE/Core/Tracing.hs view
@@ -1,195 +1,194 @@-{-# LANGUAGE DataKinds #-}
-module Development.IDE.Core.Tracing
-    ( otTracedHandler
-    , otTracedAction
-    , startTelemetry
-    , measureMemory
-    , getInstrumentCached
-    )
-where
-
-import           Control.Concurrent.Async       (Async, async)
-import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,
-                                                 readVar, threadDelay)
-import           Control.Exception              (evaluate)
-import           Control.Exception.Safe         (catch, SomeException)
-import           Control.Monad                  (void, when, unless, forM_, forever, (>=>))
-import           Control.Monad.Extra            (whenJust)
-import           Control.Seq                    (r0, seqList, seqTuple2, using)
-import           Data.Dynamic                   (Dynamic)
-import qualified Data.HashMap.Strict            as HMap
-import           Data.IORef                     (modifyIORef', newIORef,
-                                                 readIORef, writeIORef)
-import           Data.List                      (nub)
-import           Data.String                    (IsString (fromString))
-import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
-                                                 GhcSessionDeps (GhcSessionDeps),
-                                                 GhcSessionIO (GhcSessionIO))
-import           Development.IDE.Types.Logger   (logInfo, Logger, logDebug)
-import           Development.IDE.Types.Shake    (Key (..), Value, Values)
-import           Development.Shake              (Action, actionBracket, liftIO)
-import           Ide.PluginUtils                (installSigUsr1Handler)
-import           Foreign.Storable               (Storable (sizeOf))
-import           HeapSize                       (recursiveSize, runHeapsize)
-import           Language.Haskell.LSP.Types     (NormalizedFilePath,
-                                                 fromNormalizedFilePath)
-import           Numeric.Natural                (Natural)
-import           OpenTelemetry.Eventlog         (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,
-                                                 mkValueObserver, observe,
-                                                 setTag, withSpan, withSpan_)
-
--- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
-otTracedHandler
-    :: String -- ^ Message type
-    -> String -- ^ Message label
-    -> IO a
-    -> IO a
-otTracedHandler requestType label act =
-  let !name =
-        if null label
-          then requestType
-          else requestType <> ":" <> show label
-   -- Add an event so all requests can be quickly seen in the viewer without searching
-   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act)
-
--- | Trace a Shake action using opentelemetry.
-otTracedAction
-    :: Show k
-    => k -- ^ The Action's Key
-    -> NormalizedFilePath -- ^ Path to the file the action was run for
-    -> (a -> Bool) -- ^ Did this action succeed?
-    -> Action a -- ^ The action
-    -> Action a
-otTracedAction key file success act = actionBracket
-    (do
-        sp <- beginSpan (fromString (show key))
-        setTag sp "File" (fromString $ fromNormalizedFilePath file)
-        return sp
-    )
-    endSpan
-    (\sp -> do
-        res <- act
-        unless (success res) $ setTag sp "error" "1"
-        return res)
-
-startTelemetry :: Bool -> Logger -> Var Values -> IO ()
-startTelemetry allTheTime logger stateRef = do
-    instrumentFor <- getInstrumentCached
-    mapCountInstrument <- mkValueObserver "values map count"
-
-    installSigUsr1Handler $ do
-        logInfo logger "SIGUSR1 received: performing memory measurement"
-        performMeasurement logger stateRef instrumentFor mapCountInstrument
-
-    when allTheTime $ void $ regularly (1 * seconds) $
-        performMeasurement logger stateRef instrumentFor mapCountInstrument
-  where
-        seconds = 1000000
-
-        regularly :: Int -> IO () -> IO (Async ())
-        regularly delay act = async $ forever (act >> threadDelay delay)
-
-
-performMeasurement ::
-  Logger ->
-  Var (HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)) ->
-  (Maybe Key -> IO OurValueObserver) ->
-  Instrument 'Asynchronous a m' ->
-  IO ()
-performMeasurement logger stateRef instrumentFor mapCountInstrument = do
-    withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length
-
-    values <- readVar stateRef
-    let keys = Key GhcSession
-             : Key GhcSessionDeps
-             : [ k | (_,k) <- HMap.keys values
-                        -- do GhcSessionIO last since it closes over stateRef itself
-                        , k /= Key GhcSession
-                        , k /= Key GhcSessionDeps
-                        , k /= Key GhcSessionIO
-             ] ++ [Key GhcSessionIO]
-    groupedForSharing <- evaluate (keys `using` seqList r0)
-    measureMemory logger [groupedForSharing] instrumentFor stateRef
-        `catch` \(e::SomeException) ->
-        logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e))
-
-
-type OurValueObserver = Int -> IO ()
-
-getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)
-getInstrumentCached = do
-    instrumentMap <- newVar HMap.empty
-    mapBytesInstrument <- mkValueObserver "value map size_bytes"
-
-    let instrumentFor k = do
-          mb_inst <- HMap.lookup k <$> readVar instrumentMap
-          case mb_inst of
-            Nothing -> do
-                instrument <- mkValueObserver (fromString (show k ++ " size_bytes"))
-                modifyVar_ instrumentMap (return . HMap.insert k instrument)
-                return $ observe instrument
-            Just v -> return $ observe v
-    return $ maybe (return $ observe mapBytesInstrument) instrumentFor
-
-whenNothing :: IO () -> IO (Maybe a) -> IO ()
-whenNothing act mb = mb >>= f
-  where f Nothing = act
-        f Just{}  = return ()
-
-measureMemory
-    :: Logger
-    -> [[Key]]     -- ^ Grouping of keys for the sharing-aware analysis
-    -> (Maybe Key -> IO OurValueObserver)
-    -> Var Values
-    -> IO ()
-measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do
-    values <- readVar stateRef
-    valuesSizeRef <- newIORef $ Just 0
-    let !groupsOfGroupedValues = groupValues values
-    logDebug logger "STARTING MEMORY PROFILING"
-    forM_ groupsOfGroupedValues $ \groupedValues -> do
-        keepGoing <- readIORef valuesSizeRef
-        whenJust keepGoing $ \_ ->
-          whenNothing (writeIORef valuesSizeRef Nothing) $
-          repeatUntilJust 3 $ do
-          -- logDebug logger (fromString $ show $ map fst groupedValues)
-          runHeapsize 25000000 $
-              forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do
-              acc <- liftIO $ newIORef 0
-              observe <- liftIO $ instrumentFor $ Just k
-              mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v
-              size <- liftIO $ readIORef acc
-              let !byteSize = sizeOf (undefined :: Word) * size
-              setTag sp "size" (fromString (show byteSize ++ " bytes"))
-              () <- liftIO $ observe byteSize
-              liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize))
-
-    mbValuesSize <- readIORef valuesSizeRef
-    case mbValuesSize of
-        Just valuesSize -> do
-            observe <- instrumentFor Nothing
-            observe valuesSize
-            logDebug logger "MEMORY PROFILING COMPLETED"
-        Nothing ->
-            logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"
-
-    where
-        groupValues :: Values -> [ [(Key, [Value Dynamic])] ]
-        groupValues values =
-            let !groupedValues =
-                    [ [ (k, vv)
-                      | k <- groupKeys
-                      , let vv = [ v | ((_,k'), v) <- HMap.toList values , k == k']
-                      ]
-                    | groupKeys <- groups
-                    ]
-                -- force the spine of the nested lists
-            in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0)))
-
-repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)
-repeatUntilJust 0 _ = return Nothing
-repeatUntilJust nattempts action = do
-    res <- action
-    case res of
-        Nothing -> repeatUntilJust (nattempts-1) action
-        Just{}  -> return res
+{-# LANGUAGE DataKinds #-}+module Development.IDE.Core.Tracing+    ( otTracedHandler+    , otTracedAction+    , startTelemetry+    , measureMemory+    , getInstrumentCached+    )+where++import           Control.Concurrent.Async       (Async, async)+import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,+                                                 readVar, threadDelay)+import           Control.Exception              (evaluate)+import           Control.Exception.Safe         (catch, SomeException)+import           Control.Monad                  (void, when, unless, forM_, forever, (>=>))+import           Control.Monad.Extra            (whenJust)+import           Control.Seq                    (r0, seqList, seqTuple2, using)+import           Data.Dynamic                   (Dynamic)+import qualified Data.HashMap.Strict            as HMap+import           Data.IORef                     (modifyIORef', newIORef,+                                                 readIORef, writeIORef)+import           Data.String                    (IsString (fromString))+import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),+                                                 GhcSessionDeps (GhcSessionDeps),+                                                 GhcSessionIO (GhcSessionIO))+import           Development.IDE.Types.Logger   (logInfo, Logger, logDebug)+import           Development.IDE.Types.Shake    (ValueWithDiagnostics(..), Key (..), Value, Values)+import           Development.Shake              (Action, actionBracket, liftIO)+import           Ide.PluginUtils                (installSigUsr1Handler)+import           Foreign.Storable               (Storable (sizeOf))+import           HeapSize                       (recursiveSize, runHeapsize)+import           Language.Haskell.LSP.Types     (NormalizedFilePath,+                                                 fromNormalizedFilePath)+import           Numeric.Natural                (Natural)+import           OpenTelemetry.Eventlog         (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,+                                                 mkValueObserver, observe,+                                                 setTag, withSpan, withSpan_)++-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.+otTracedHandler+    :: String -- ^ Message type+    -> String -- ^ Message label+    -> IO a+    -> IO a+otTracedHandler requestType label act =+  let !name =+        if null label+          then requestType+          else requestType <> ":" <> show label+   -- Add an event so all requests can be quickly seen in the viewer without searching+   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act)++-- | Trace a Shake action using opentelemetry.+otTracedAction+    :: Show k+    => k -- ^ The Action's Key+    -> NormalizedFilePath -- ^ Path to the file the action was run for+    -> (a -> Bool) -- ^ Did this action succeed?+    -> Action a -- ^ The action+    -> Action a+otTracedAction key file success act = actionBracket+    (do+        sp <- beginSpan (fromString (show key))+        setTag sp "File" (fromString $ fromNormalizedFilePath file)+        return sp+    )+    endSpan+    (\sp -> do+        res <- act+        unless (success res) $ setTag sp "error" "1"+        return res)++startTelemetry :: Bool -> Logger -> Var Values -> IO ()+startTelemetry allTheTime logger stateRef = do+    instrumentFor <- getInstrumentCached+    mapCountInstrument <- mkValueObserver "values map count"++    installSigUsr1Handler $ do+        logInfo logger "SIGUSR1 received: performing memory measurement"+        performMeasurement logger stateRef instrumentFor mapCountInstrument++    when allTheTime $ void $ regularly (1 * seconds) $+        performMeasurement logger stateRef instrumentFor mapCountInstrument+  where+        seconds = 1000000++        regularly :: Int -> IO () -> IO (Async ())+        regularly delay act = async $ forever (act >> threadDelay delay)+++performMeasurement ::+  Logger ->+  Var Values ->+  (Maybe Key -> IO OurValueObserver) ->+  Instrument 'Asynchronous a m' ->+  IO ()+performMeasurement logger stateRef instrumentFor mapCountInstrument = do+    withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length++    values <- readVar stateRef+    let keys = Key GhcSession+             : Key GhcSessionDeps+             : [ k | (_,k) <- HMap.keys values+                        -- do GhcSessionIO last since it closes over stateRef itself+                        , k /= Key GhcSession+                        , k /= Key GhcSessionDeps+                        , k /= Key GhcSessionIO+             ] ++ [Key GhcSessionIO]+    groupedForSharing <- evaluate (keys `using` seqList r0)+    measureMemory logger [groupedForSharing] instrumentFor stateRef+        `catch` \(e::SomeException) ->+        logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e))+++type OurValueObserver = Int -> IO ()++getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)+getInstrumentCached = do+    instrumentMap <- newVar HMap.empty+    mapBytesInstrument <- mkValueObserver "value map size_bytes"++    let instrumentFor k = do+          mb_inst <- HMap.lookup k <$> readVar instrumentMap+          case mb_inst of+            Nothing -> do+                instrument <- mkValueObserver (fromString (show k ++ " size_bytes"))+                modifyVar_ instrumentMap (return . HMap.insert k instrument)+                return $ observe instrument+            Just v -> return $ observe v+    return $ maybe (return $ observe mapBytesInstrument) instrumentFor++whenNothing :: IO () -> IO (Maybe a) -> IO ()+whenNothing act mb = mb >>= f+  where f Nothing = act+        f Just{}  = return ()++measureMemory+    :: Logger+    -> [[Key]]     -- ^ Grouping of keys for the sharing-aware analysis+    -> (Maybe Key -> IO OurValueObserver)+    -> Var Values+    -> IO ()+measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do+    values <- readVar stateRef+    valuesSizeRef <- newIORef $ Just 0+    let !groupsOfGroupedValues = groupValues values+    logDebug logger "STARTING MEMORY PROFILING"+    forM_ groupsOfGroupedValues $ \groupedValues -> do+        keepGoing <- readIORef valuesSizeRef+        whenJust keepGoing $ \_ ->+          whenNothing (writeIORef valuesSizeRef Nothing) $+          repeatUntilJust 3 $ do+          -- logDebug logger (fromString $ show $ map fst groupedValues)+          runHeapsize 25000000 $+              forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do+              acc <- liftIO $ newIORef 0+              observe <- liftIO $ instrumentFor $ Just k+              mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v+              size <- liftIO $ readIORef acc+              let !byteSize = sizeOf (undefined :: Word) * size+              setTag sp "size" (fromString (show byteSize ++ " bytes"))+              () <- liftIO $ observe byteSize+              liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize))++    mbValuesSize <- readIORef valuesSizeRef+    case mbValuesSize of+        Just valuesSize -> do+            observe <- instrumentFor Nothing+            observe valuesSize+            logDebug logger "MEMORY PROFILING COMPLETED"+        Nothing ->+            logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"++    where+        groupValues :: Values -> [ [(Key, [Value Dynamic])] ]+        groupValues values =+            let !groupedValues =+                    [ [ (k, vv)+                      | k <- groupKeys+                      , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k']+                      ]+                    | groupKeys <- groups+                    ]+                -- force the spine of the nested lists+            in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0)))++repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)+repeatUntilJust 0 _ = return Nothing+repeatUntilJust nattempts action = do+    res <- action+    case res of+        Nothing -> repeatUntilJust (nattempts-1) action+        Just{}  -> return res
src/Development/IDE/GHC/CPP.hs view
@@ -1,228 +1,228 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019
--- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.
--- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.
-
-{- HLINT ignore -} -- since copied from upstream
-
-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-#include "ghc-api-version.h"
-
------------------------------------------------------------------------------
---
--- GHC Driver
---
--- (c) The University of Glasgow 2005
---
------------------------------------------------------------------------------
-
-module Development.IDE.GHC.CPP(doCpp, addOptP)
-where
-
-import Development.IDE.GHC.Compat
-import Packages
-import SysTools
-import Module
-import Panic
-import FileCleanup
-#if MIN_GHC_API_VERSION(8,8,2)
-import LlvmCodeGen (llvmVersionList)
-#elif MIN_GHC_API_VERSION(8,8,0)
-import LlvmCodeGen (LlvmVersion (..))
-#endif
-#if MIN_GHC_API_VERSION (8,10,0)
-import Fingerprint
-import ToolSettings
-#endif
-
-import System.Directory
-import System.FilePath
-import Control.Monad
-import System.Info
-import Data.List        ( intercalate )
-import Data.Maybe
-import Data.Version
-
-
-
-doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
-doCpp dflags raw input_fn output_fn = do
-    let hscpp_opts = picPOpts dflags
-    let cmdline_include_paths = includePaths dflags
-
-    pkg_include_dirs <- getPackageIncludePath dflags []
-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
-          (includePathsQuote cmdline_include_paths)
-    let include_paths = include_paths_quote ++ include_paths_global
-
-    let verbFlags = getVerbFlags dflags
-
-    let cpp_prog args | raw       = SysTools.runCpp dflags args
-#if MIN_GHC_API_VERSION(8,10,0)
-                      | otherwise = SysTools.runCc Nothing
-#else
-                      | otherwise = SysTools.runCc
-#endif
-                                          dflags (SysTools.Option "-E" : args)
-
-    let target_defs =
-          -- NEIL: Patched to use System.Info instead of constants from CPP
-          [ "-D" ++ os     ++ "_BUILD_OS",
-            "-D" ++ arch   ++ "_BUILD_ARCH",
-            "-D" ++ os     ++ "_HOST_OS",
-            "-D" ++ arch   ++ "_HOST_ARCH" ]
-        -- remember, in code we *compile*, the HOST is the same our TARGET,
-        -- and BUILD is the same as our HOST.
-
-    let sse_defs =
-          [ "-D__SSE__"      | isSseEnabled      dflags ] ++
-          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]
-
-    let avx_defs =
-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
-
-    backend_defs <- getBackendDefs dflags
-
-    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-    -- Default CPP defines in Haskell source
-    ghcVersionH <- getGhcVersionPathName dflags
-    let hsSourceCppOpts = [ "-include", ghcVersionH ]
-
-    -- MIN_VERSION macros
-    let uids = explicitPackages (pkgState dflags)
-        pkgs = catMaybes (map (lookupPackage dflags) uids)
-    mb_macro_include <-
-        if not (null pkgs) && gopt Opt_VersionMacros dflags
-            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
-                    writeFile macro_stub (generatePackageVersionMacros pkgs)
-                    -- Include version macros for every *exposed* package.
-                    -- Without -hide-all-packages and with a package database
-                    -- size of 1000 packages, it takes cpp an estimated 2
-                    -- milliseconds to process this file. See #10970
-                    -- comment 8.
-                    return [SysTools.FileOption "-include" macro_stub]
-            else return []
-
-    cpp_prog       (   map SysTools.Option verbFlags
-                    ++ map SysTools.Option include_paths
-                    ++ map SysTools.Option hsSourceCppOpts
-                    ++ map SysTools.Option target_defs
-                    ++ map SysTools.Option backend_defs
-                    ++ map SysTools.Option th_defs
-                    ++ map SysTools.Option hscpp_opts
-                    ++ map SysTools.Option sse_defs
-                    ++ map SysTools.Option avx_defs
-                    ++ mb_macro_include
-        -- Set the language mode to assembler-with-cpp when preprocessing. This
-        -- alleviates some of the C99 macro rules relating to whitespace and the hash
-        -- operator, which we tend to abuse. Clang in particular is not very happy
-        -- about this.
-                    ++ [ SysTools.Option     "-x"
-                       , SysTools.Option     "assembler-with-cpp"
-                       , SysTools.Option     input_fn
-        -- We hackily use Option instead of FileOption here, so that the file
-        -- name is not back-slashed on Windows.  cpp is capable of
-        -- dealing with / in filenames, so it works fine.  Furthermore
-        -- if we put in backslashes, cpp outputs #line directives
-        -- with *double* backslashes.   And that in turn means that
-        -- our error messages get double backslashes in them.
-        -- In due course we should arrange that the lexer deals
-        -- with these \\ escapes properly.
-                       , SysTools.Option     "-o"
-                       , SysTools.FileOption "" output_fn
-                       ])
-
-getBackendDefs :: DynFlags -> IO [String]
-getBackendDefs dflags | hscTarget dflags == HscLlvm = do
-    llvmVer <- figureLlvmVersion dflags
-    return $ case llvmVer of
-#if MIN_GHC_API_VERSION(8,8,2)
-               Just v
-                 | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
-                 | m:n:_   <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
-#elif MIN_GHC_API_VERSION(8,8,0)
-               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
-               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
-#else
-               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
-#endif
-               _      -> []
-  where
-    format (major, minor)
-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"
-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
-
-getBackendDefs _ =
-    return []
-
-addOptP :: String -> DynFlags -> DynFlags
-#if MIN_GHC_API_VERSION (8,10,0)
-addOptP f = alterToolSettings $ \s -> s
-          { toolSettings_opt_P             = f : toolSettings_opt_P s
-          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
-          }
-  where
-    fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
-    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
-#else
-addOptP opt = onSettings (onOptP (opt:))
-  where
-    onSettings f x = x{settings = f $ settings x}
-    onOptP f x = x{sOpt_P = f $ sOpt_P x}
-#endif
-
--- ---------------------------------------------------------------------------
--- Macros (cribbed from Cabal)
-
-generatePackageVersionMacros :: [PackageConfig] -> String
-generatePackageVersionMacros pkgs = concat
-  -- Do not add any C-style comments. See #3389.
-  [ generateMacros "" pkgname version
-  | pkg <- pkgs
-  , let version = packageVersion pkg
-        pkgname = map fixchar (packageNameString pkg)
-  ]
-
-fixchar :: Char -> Char
-fixchar '-' = '_'
-fixchar c   = c
-
-generateMacros :: String -> String -> Version -> String
-generateMacros prefix name version =
-  concat
-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
-  ,"  (major1) <  ",major1," || \\\n"
-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
-  ,"\n\n"
-  ]
-  where
-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
-
-
--- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> IO FilePath
-getGhcVersionPathName dflags = do
-  candidates <- case ghcVersionFile dflags of
-    Just path -> return [path]
-    Nothing -> (map (</> "ghcversion.h")) <$>
-               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
-
-  found <- filterM doesFileExist candidates
-  case found of
-      []    -> throwGhcExceptionIO (InstallationError
-                                    ("ghcversion.h missing; tried: "
-                                      ++ intercalate ", " candidates))
-      (x:_) -> return x
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019+-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.+-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.++{- HLINT ignore -} -- since copied from upstream++{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#include "ghc-api-version.h"++-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Development.IDE.GHC.CPP(doCpp, addOptP)+where++import Development.IDE.GHC.Compat+import Packages+import SysTools+import Module+import Panic+import FileCleanup+#if MIN_GHC_API_VERSION(8,8,2)+import LlvmCodeGen (llvmVersionList)+#elif MIN_GHC_API_VERSION(8,8,0)+import LlvmCodeGen (LlvmVersion (..))+#endif+#if MIN_GHC_API_VERSION (8,10,0)+import Fingerprint+import ToolSettings+#endif++import System.Directory+import System.FilePath+import Control.Monad+import System.Info+import Data.List        ( intercalate )+import Data.Maybe+import Data.Version++++doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = includePaths dflags++    pkg_include_dirs <- getPackageIncludePath dflags []+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = SysTools.runCpp dflags args+#if MIN_GHC_API_VERSION(8,10,0)+                      | otherwise = SysTools.runCc Nothing+#else+                      | otherwise = SysTools.runCc+#endif+                                          dflags (SysTools.Option "-E" : args)++    let target_defs =+          -- NEIL: Patched to use System.Info instead of constants from CPP+          [ "-D" ++ os     ++ "_BUILD_OS",+            "-D" ++ arch   ++ "_BUILD_ARCH",+            "-D" ++ os     ++ "_HOST_OS",+            "-D" ++ arch   ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      dflags ] +++          [ "-D__SSE2__"     | isSse2Enabled     dflags ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitPackages (pkgState dflags)+        pkgs = catMaybes (map (lookupPackage dflags) uids)+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map SysTools.Option verbFlags+                    ++ map SysTools.Option include_paths+                    ++ map SysTools.Option hsSourceCppOpts+                    ++ map SysTools.Option target_defs+                    ++ map SysTools.Option backend_defs+                    ++ map SysTools.Option th_defs+                    ++ map SysTools.Option hscpp_opts+                    ++ map SysTools.Option sse_defs+                    ++ map SysTools.Option avx_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ SysTools.Option     "-x"+                       , SysTools.Option     "assembler-with-cpp"+                       , SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , SysTools.Option     "-o"+                       , SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: DynFlags -> IO [String]+getBackendDefs dflags | hscTarget dflags == HscLlvm = do+    llvmVer <- figureLlvmVersion dflags+    return $ case llvmVer of+#if MIN_GHC_API_VERSION(8,8,2)+               Just v+                 | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]+                 | m:n:_   <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]+#elif MIN_GHC_API_VERSION(8,8,0)+               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]+               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+#else+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+#endif+               _      -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ =+    return []++addOptP :: String -> DynFlags -> DynFlags+#if MIN_GHC_API_VERSION (8,10,0)+addOptP f = alterToolSettings $ \s -> s+          { toolSettings_opt_P             = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+  where+    fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss+    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }+#else+addOptP opt = onSettings (onOptP (opt:))+  where+    onSettings f x = x{settings = f $ settings x}+    onOptP f x = x{sOpt_P = f $ sOpt_P x}+#endif++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [PackageConfig] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = packageVersion pkg+        pkgname = map fixchar (packageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> IO FilePath+getGhcVersionPathName dflags = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> (map (</> "ghcversion.h")) <$>+               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])++  found <- filterM doesFileExist candidates+  case found of+      []    -> throwGhcExceptionIO (InstallationError+                                    ("ghcversion.h missing; tried: "+                                      ++ intercalate ", " candidates))+      (x:_) -> return x
src/Development/IDE/GHC/Compat.hs view
@@ -1,285 +1,294 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-}
-#include "ghc-api-version.h"
-
--- | Attempt at hiding the GHC version differences we can.
-module Development.IDE.GHC.Compat(
-    HieFileResult(..),
-    HieFile(..),
-    NameCacheUpdater(..),
-    hieExportNames,
-    mkHieFile,
-    mkHieFile',
-    enrichHie,
-    RefMap,
-    writeHieFile,
-    readHieFile,
-    supportsHieFiles,
-    setHieDir,
-    dontWriteHieFiles,
-#if !MIN_GHC_API_VERSION(8,8,0)
-    ml_hie_file,
-    addBootSuffixLocnOut,
-#endif
-    hPutStringBuffer,
-    addIncludePathsQuote,
-    getModuleHash,
-    getPackageName,
-    setUpTypedHoles,
-    GHC.ModLocation,
-    Module.addBootSuffix,
-    pattern ModLocation,
-    pattern ExposePackage,
-    HasSrcSpan,
-    getLoc,
-    upNameCache,
-    disableWarningsAsErrors,
-    AvailInfo,
-    tcg_exports,
-
-#if MIN_GHC_API_VERSION(8,10,0)
-    module GHC.Hs.Extension,
-    module LinkerTypes,
-#else
-    module HsExtension,
-    noExtField,
-    linkableTime,
-#endif
-
-    module GHC,
-    module DynFlags,
-    initializePlugins,
-    applyPluginsParsedResultAction,
-    module Compat.HieTypes,
-    module Compat.HieUtils,
-
-    ) where
-
-#if MIN_GHC_API_VERSION(8,10,0)
-import LinkerTypes
-#endif
-
-import StringBuffer
-import qualified DynFlags
-import DynFlags hiding (ExposePackage)
-import Fingerprint (Fingerprint)
-import qualified Module
-import Packages
-import Data.IORef
-import HscTypes
-import NameCache
-import qualified Data.ByteString as BS
-import MkIface
-import TcRnTypes
-import Compat.HieAst (mkHieFile,enrichHie)
-import Compat.HieBin
-import Compat.HieTypes
-import Compat.HieUtils
-
-#if MIN_GHC_API_VERSION(8,10,0)
-import GHC.Hs.Extension
-#else
-import HsExtension
-#endif
-
-import qualified GHC
-import GHC hiding (
-      ModLocation,
-      HasSrcSpan,
-      lookupName,
-      getLoc
-    )
-import Avail
-#if MIN_GHC_API_VERSION(8,8,0)
-import Data.List (foldl')
-#else
-import Data.List (foldl', isSuffixOf)
-#endif
-
-import DynamicLoading
-import Plugins (Plugin(parsedResultAction), withPlugins)
-import Data.Map.Strict (Map)
-
-#if !MIN_GHC_API_VERSION(8,8,0)
-import System.FilePath ((-<.>))
-#endif
-
-#if !MIN_GHC_API_VERSION(8,8,0)
-import qualified EnumSet
-
-import System.IO
-import Foreign.ForeignPtr
-
-
-hPutStringBuffer :: Handle -> StringBuffer -> IO ()
-hPutStringBuffer hdl (StringBuffer buf len cur)
-    = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
-             hPutBuf hdl ptr len
-
-#endif
-
-#if !MIN_GHC_API_VERSION(8,10,0)
-noExtField :: NoExt
-noExtField = noExt
-#endif
-
-supportsHieFiles :: Bool
-supportsHieFiles = True
-
-hieExportNames :: HieFile -> [(SrcSpan, Name)]
-hieExportNames = nameListFromAvails . hie_exports
-
-#if !MIN_GHC_API_VERSION(8,8,0)
-ml_hie_file :: GHC.ModLocation -> FilePath
-ml_hie_file ml
-  | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot"
-  | otherwise  = ml_hi_file ml -<.> ".hie"
-#endif
-
-upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
-#if !MIN_GHC_API_VERSION(8,8,0)
-upNameCache ref upd_fn
-  = atomicModifyIORef' ref upd_fn
-#else
-upNameCache = updNameCache
-#endif
-
-
-type RefMap = Map Identifier [(Span, IdentifierDetails Type)]
-
-mkHieFile' :: ModSummary
-           -> [AvailInfo]
-           -> HieASTs Type
-           -> BS.ByteString
-           -> Hsc HieFile
-mkHieFile' ms exports asts src = do
-  let Just src_file = ml_hs_file $ ms_location ms
-      (asts',arr) = compressTypes asts
-  return $ HieFile
-      { hie_hs_file = src_file
-      , hie_module = ms_mod ms
-      , hie_types = arr
-      , hie_asts = asts'
-      -- mkIfaceExports sorts the AvailInfos for stability
-      , hie_exports = mkIfaceExports exports
-      , hie_hs_src = src
-      }
-
-addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags
-addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
-    where f i = i{includePathsQuote = path : includePathsQuote i}
-
-pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation
-pattern ModLocation a b c <-
-#if MIN_GHC_API_VERSION(8,8,0)
-    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
-#else
-    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
-#endif
-
-setHieDir :: FilePath -> DynFlags -> DynFlags
-setHieDir _f d =
-#if MIN_GHC_API_VERSION(8,8,0)
-    d { hieDir     = Just _f}
-#else
-    d
-#endif
-
-dontWriteHieFiles :: DynFlags -> DynFlags
-dontWriteHieFiles d =
-#if MIN_GHC_API_VERSION(8,8,0)
-    gopt_unset d Opt_WriteHie
-#else
-    d
-#endif
-
-setUpTypedHoles ::DynFlags -> DynFlags
-setUpTypedHoles df
-  = flip gopt_unset Opt_AbstractRefHoleFits    -- too spammy
-#if MIN_GHC_API_VERSION(8,8,0)
-  $ flip gopt_unset Opt_ShowDocsOfHoleFits     -- not used
-#endif
-  $ flip gopt_unset Opt_ShowMatchesOfHoleFits  -- nice but broken (forgets module qualifiers)
-  $ flip gopt_unset Opt_ShowProvOfHoleFits     -- not used
-  $ flip gopt_unset Opt_ShowTypeAppOfHoleFits  -- not used
-  $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used
-  $ flip gopt_unset Opt_ShowTypeOfHoleFits     -- massively simplifies parsing
-  $ flip gopt_set   Opt_SortBySubsumHoleFits   -- very nice and fast enough in most cases
-  $ flip gopt_unset Opt_SortValidHoleFits
-  $ flip gopt_unset Opt_UnclutterValidHoleFits
-  $ df
-  { refLevelHoleFits = Just 1   -- becomes slow at higher levels
-  , maxRefHoleFits   = Just 10  -- quantity does not impact speed
-  , maxValidHoleFits = Nothing  -- quantity does not impact speed
-  }
-
-
-nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
-nameListFromAvails as =
-  map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
-
-#if MIN_GHC_API_VERSION(8,8,0)
-
-type HasSrcSpan = GHC.HasSrcSpan
-getLoc :: HasSrcSpan a => a -> SrcSpan
-getLoc = GHC.getLoc
-
-#else
-
-class HasSrcSpan a where
-    getLoc :: a -> SrcSpan
-instance HasSrcSpan Name where
-    getLoc = nameSrcSpan
-instance HasSrcSpan (GenLocated SrcSpan a) where
-    getLoc = GHC.getLoc
-
--- | Add the @-boot@ suffix to all output file paths associated with the
--- module, not including the input file itself
-addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation
-addBootSuffixLocnOut locn
-  = locn { ml_hi_file  = Module.addBootSuffix (ml_hi_file locn)
-         , ml_obj_file = Module.addBootSuffix (ml_obj_file locn)
-         }
-#endif
-
-getModuleHash :: ModIface -> Fingerprint
-#if MIN_GHC_API_VERSION(8,10,0)
-getModuleHash = mi_mod_hash . mi_final_exts
-#else
-getModuleHash = mi_mod_hash
-#endif
-
-getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
-getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
-
-disableWarningsAsErrors :: DynFlags -> DynFlags
-disableWarningsAsErrors df =
-    flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]
-
-#if !MIN_GHC_API_VERSION(8,8,0)
-wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
-wopt_unset_fatal dfs f
-    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }
-#endif
-
-applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource
-applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
-  -- Apply parsedResultAction of plugins
-  let applyPluginAction p opts = parsedResultAction p opts ms
-  fmap hpm_module $
-    runHsc env $ withPlugins dflags applyPluginAction
-      (HsParsedModule parsed [] hpm_annotations)
-
-pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag
--- https://github.com/facebook/fbghc
-#ifdef __FACEBOOK_HASKELL__
-pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr
-#else
-pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr
-#endif
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-}+#include "ghc-api-version.h"++-- | Attempt at hiding the GHC version differences we can.+module Development.IDE.GHC.Compat(+    HieFileResult(..),+    HieFile(..),+    NameCacheUpdater(..),+    hieExportNames,+    mkHieFile,+    mkHieFile',+    enrichHie,+    RefMap,+    writeHieFile,+    readHieFile,+    supportsHieFiles,+    setHieDir,+    dontWriteHieFiles,+#if !MIN_GHC_API_VERSION(8,8,0)+    ml_hie_file,+    addBootSuffixLocnOut,+#endif+    hPutStringBuffer,+    addIncludePathsQuote,+    getModuleHash,+    getPackageName,+    setUpTypedHoles,+    GHC.ModLocation,+    Module.addBootSuffix,+    pattern ModLocation,+    pattern ExposePackage,+    HasSrcSpan,+    getLoc,+    upNameCache,+    disableWarningsAsErrors,+    AvailInfo,+    tcg_exports,++#if MIN_GHC_API_VERSION(8,10,0)+    module GHC.Hs.Extension,+    module LinkerTypes,+#else+    module HsExtension,+    noExtField,+    linkableTime,+#endif++    module GHC,+    module DynFlags,+    initializePlugins,+    applyPluginsParsedResultAction,+    module Compat.HieTypes,+    module Compat.HieUtils,+    dropForAll+    ) where++#if MIN_GHC_API_VERSION(8,10,0)+import LinkerTypes+#endif++import StringBuffer+import qualified DynFlags+import DynFlags hiding (ExposePackage)+import Fingerprint (Fingerprint)+import qualified Module+import Packages+import Data.IORef+import HscTypes+import NameCache+import qualified Data.ByteString as BS+import MkIface+import TcRnTypes+import Compat.HieAst (mkHieFile,enrichHie)+import Compat.HieBin+import Compat.HieTypes+import Compat.HieUtils++#if MIN_GHC_API_VERSION(8,10,0)+import GHC.Hs.Extension+#else+import HsExtension+#endif++import qualified GHC+import GHC hiding (+      ModLocation,+      HasSrcSpan,+      lookupName,+      getLoc+    )+import Avail+#if MIN_GHC_API_VERSION(8,8,0)+import Data.List (foldl')+#else+import Data.List (foldl', isSuffixOf)+#endif++import DynamicLoading+import Plugins (Plugin(parsedResultAction), withPlugins)+import Data.Map.Strict (Map)++#if !MIN_GHC_API_VERSION(8,8,0)+import System.FilePath ((-<.>))+#endif++#if !MIN_GHC_API_VERSION(8,8,0)+import qualified EnumSet++import System.IO+import Foreign.ForeignPtr+++hPutStringBuffer :: Handle -> StringBuffer -> IO ()+hPutStringBuffer hdl (StringBuffer buf len cur)+    = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->+             hPutBuf hdl ptr len++#endif++#if !MIN_GHC_API_VERSION(8,10,0)+noExtField :: NoExt+noExtField = noExt+#endif++supportsHieFiles :: Bool+supportsHieFiles = True++hieExportNames :: HieFile -> [(SrcSpan, Name)]+hieExportNames = nameListFromAvails . hie_exports++#if !MIN_GHC_API_VERSION(8,8,0)+ml_hie_file :: GHC.ModLocation -> FilePath+ml_hie_file ml+  | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot"+  | otherwise  = ml_hi_file ml -<.> ".hie"+#endif++upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c+#if !MIN_GHC_API_VERSION(8,8,0)+upNameCache ref upd_fn+  = atomicModifyIORef' ref upd_fn+#else+upNameCache = updNameCache+#endif+++type RefMap = Map Identifier [(Span, IdentifierDetails Type)]++mkHieFile' :: ModSummary+           -> [AvailInfo]+           -> HieASTs Type+           -> BS.ByteString+           -> Hsc HieFile+mkHieFile' ms exports asts src = do+  let Just src_file = ml_hs_file $ ms_location ms+      (asts',arr) = compressTypes asts+  return $ HieFile+      { hie_hs_file = src_file+      , hie_module = ms_mod ms+      , hie_types = arr+      , hie_asts = asts'+      -- mkIfaceExports sorts the AvailInfos for stability+      , hie_exports = mkIfaceExports exports+      , hie_hs_src = src+      }++addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags+addIncludePathsQuote path x = x{includePaths = f $ includePaths x}+    where f i = i{includePathsQuote = path : includePathsQuote i}++pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation+pattern ModLocation a b c <-+#if MIN_GHC_API_VERSION(8,8,0)+    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""+#else+    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c+#endif++setHieDir :: FilePath -> DynFlags -> DynFlags+setHieDir _f d =+#if MIN_GHC_API_VERSION(8,8,0)+    d { hieDir     = Just _f}+#else+    d+#endif++dontWriteHieFiles :: DynFlags -> DynFlags+dontWriteHieFiles d =+#if MIN_GHC_API_VERSION(8,8,0)+    gopt_unset d Opt_WriteHie+#else+    d+#endif++setUpTypedHoles ::DynFlags -> DynFlags+setUpTypedHoles df+  = flip gopt_unset Opt_AbstractRefHoleFits    -- too spammy+#if MIN_GHC_API_VERSION(8,8,0)+  $ flip gopt_unset Opt_ShowDocsOfHoleFits     -- not used+#endif+  $ flip gopt_unset Opt_ShowMatchesOfHoleFits  -- nice but broken (forgets module qualifiers)+  $ flip gopt_unset Opt_ShowProvOfHoleFits     -- not used+  $ flip gopt_unset Opt_ShowTypeAppOfHoleFits  -- not used+  $ flip gopt_unset Opt_ShowTypeAppVarsOfHoleFits -- not used+  $ flip gopt_unset Opt_ShowTypeOfHoleFits     -- massively simplifies parsing+  $ flip gopt_set   Opt_SortBySubsumHoleFits   -- very nice and fast enough in most cases+  $ flip gopt_unset Opt_SortValidHoleFits+  $ flip gopt_unset Opt_UnclutterValidHoleFits+  $ df+  { refLevelHoleFits = Just 1   -- becomes slow at higher levels+  , maxRefHoleFits   = Just 10  -- quantity does not impact speed+  , maxValidHoleFits = Nothing  -- quantity does not impact speed+  }+++nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]+nameListFromAvails as =+  map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)++#if MIN_GHC_API_VERSION(8,8,0)++type HasSrcSpan = GHC.HasSrcSpan+getLoc :: HasSrcSpan a => a -> SrcSpan+getLoc = GHC.getLoc++#else++class HasSrcSpan a where+    getLoc :: a -> SrcSpan+instance HasSrcSpan Name where+    getLoc = nameSrcSpan+instance HasSrcSpan (GenLocated SrcSpan a) where+    getLoc = GHC.getLoc++-- | Add the @-boot@ suffix to all output file paths associated with the+-- module, not including the input file itself+addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation+addBootSuffixLocnOut locn+  = locn { ml_hi_file  = Module.addBootSuffix (ml_hi_file locn)+         , ml_obj_file = Module.addBootSuffix (ml_obj_file locn)+         }+#endif++getModuleHash :: ModIface -> Fingerprint+#if MIN_GHC_API_VERSION(8,10,0)+getModuleHash = mi_mod_hash . mi_final_exts+#else+getModuleHash = mi_mod_hash+#endif++getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))++disableWarningsAsErrors :: DynFlags -> DynFlags+disableWarningsAsErrors df =+    flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]++#if !MIN_GHC_API_VERSION(8,8,0)+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }+#endif++applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource+applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do+  -- Apply parsedResultAction of plugins+  let applyPluginAction p opts = parsedResultAction p opts ms+  fmap hpm_module $+    runHsc env $ withPlugins dflags applyPluginAction+      (HsParsedModule parsed [] hpm_annotations)++pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag+-- https://github.com/facebook/fbghc+#ifdef __FACEBOOK_HASKELL__+pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr+#else+pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr+#endif++-- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body+dropForAll :: LHsType pass -> LHsType pass+#if MIN_GHC_API_VERSION(8,10,0)+dropForAll = snd . GHC.splitLHsForAllTyInvis+#else+dropForAll = snd . GHC.splitLHsForAllTy+#endif+
src/Development/IDE/GHC/Error.hs view
@@ -1,195 +1,195 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-module Development.IDE.GHC.Error
-  (
-    -- * Producing Diagnostic values
-    diagFromErrMsgs
-  , diagFromErrMsg
-  , diagFromString
-  , diagFromStrings
-  , diagFromGhcException
-  , catchSrcErrors
-
-  -- * utilities working with spans
-  , srcSpanToLocation
-  , srcSpanToRange
-  , realSrcSpanToRange
-  , realSrcLocToPosition
-  , srcSpanToFilename
-  , zeroSpan
-  , realSpan
-  , isInsideSrcSpan
-  , noSpan
-
-  -- * utilities working with severities
-  , toDSeverity
-  ) where
-
-import                     Development.IDE.Types.Diagnostics as D
-import qualified           Data.Text as T
-import Data.Maybe
-import Development.IDE.Types.Location
-import Development.IDE.GHC.Orphans()
-import qualified FastString as FS
-import           GHC
-import           Bag
-import HscTypes
-import Panic
-import           ErrUtils
-import           SrcLoc
-import qualified Outputable                 as Out
-
-
-
-diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
-diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,)
-    Diagnostic
-    { _range    = fromMaybe noRange $ srcSpanToRange loc
-    , _severity = Just sev
-    , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers
-    , _message  = msg
-    , _code     = Nothing
-    , _relatedInformation = Nothing
-    , _tags     = Nothing
-    }
-
--- | Produce a GHC-style error from a source span and a message.
-diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
-diagFromErrMsg diagSource dflags e =
-    [ diagFromText diagSource sev (errMsgSpan e)
-      $ T.pack $ formatErrorWithQual dflags e
-    | Just sev <- [toDSeverity $ errMsgSeverity e]]
-
-formatErrorWithQual :: DynFlags -> ErrMsg -> String
-formatErrorWithQual dflags e =
-    Out.showSDoc dflags
-    $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e)
-    $ ErrUtils.formatErrDoc dflags
-    $ ErrUtils.errMsgDoc e
-
-diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
-diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
-
--- | Convert a GHC SrcSpan to a DAML compiler Range
-srcSpanToRange :: SrcSpan -> Maybe Range
-srcSpanToRange (UnhelpfulSpan _)  = Nothing
-srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real
-
-realSrcSpanToRange :: RealSrcSpan -> Range
-realSrcSpanToRange real =
-  Range (realSrcLocToPosition $ realSrcSpanStart real)
-        (realSrcLocToPosition $ realSrcSpanEnd   real)
-
-realSrcLocToPosition :: RealSrcLoc -> Position
-realSrcLocToPosition real =
-  Position (srcLocLine real - 1) (srcLocCol real - 1)
-
--- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones)
--- FIXME This may not be an _absolute_ file name, needs fixing.
-srcSpanToFilename :: SrcSpan -> Maybe FilePath
-srcSpanToFilename (UnhelpfulSpan _) = Nothing
-srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real
-
-srcSpanToLocation :: SrcSpan -> Maybe Location
-srcSpanToLocation src = do
-  fs <- srcSpanToFilename src
-  rng <- srcSpanToRange src
-  -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
-  pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng
-
-isInsideSrcSpan :: Position -> SrcSpan -> Bool
-p `isInsideSrcSpan` r = case srcSpanToRange r of
-  Just (Range sp ep) -> sp <= p && p <= ep
-  _ -> False
-
--- | Convert a GHC severity to a DAML compiler Severity. Severities below
--- "Warning" level are dropped (returning Nothing).
-toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity
-toDSeverity SevOutput      = Nothing
-toDSeverity SevInteractive = Nothing
-toDSeverity SevDump        = Nothing
-toDSeverity SevInfo        = Just DsInfo
-toDSeverity SevWarning     = Just DsWarning
-toDSeverity SevError       = Just DsError
-toDSeverity SevFatal       = Just DsError
-
-
--- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given
---   (optional) locations and message strings.
-diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]
-diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))
-
--- | Produce a GHC-style error from a source span and a message.
-diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]
-diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]
-
-
--- | Produces an "unhelpful" source span with the given string.
-noSpan :: String -> SrcSpan
-noSpan = UnhelpfulSpan . FS.fsLit
-
-
--- | creates a span with zero length in the filename of the argument passed
-zeroSpan :: FS.FastString -- ^ file path of span
-         -> RealSrcSpan
-zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1)
-
-realSpan :: SrcSpan
-         -> Maybe RealSrcSpan
-realSpan = \case
-  RealSrcSpan r -> Just r
-  UnhelpfulSpan _ -> Nothing
-
-
--- | Catch the errors thrown by GHC (SourceErrors and
--- compiler-internal exceptions like Panic or InstallationError), and turn them into
--- diagnostics
-catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a)
-catchSrcErrors dflags fromWhere ghcM = do
-    handleGhcException (ghcExceptionToDiagnostics dflags) $
-      handleSourceError (sourceErrorToDiagnostics dflags) $
-      Right <$> ghcM
-    where
-        ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
-        sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
-
-
-diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
-diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)
-
-showGHCE :: DynFlags -> GhcException -> String
-showGHCE dflags exc = case exc of
-        Signal n
-          -> "Signal: " <> show n
-
-        Panic s
-          -> unwords ["Compilation Issue:", s, "\n", requestReport]
-        PprPanic  s sdoc
-          -> unlines ["Compilation Issue", s,""
-                     , Out.showSDoc dflags sdoc
-                     , requestReport ]
-
-        Sorry s
-          -> "Unsupported feature: " <> s
-        PprSorry s sdoc
-          -> unlines ["Unsupported feature: ", s,""
-                     , Out.showSDoc dflags sdoc]
-
-
-        ---------- errors below should not happen at all --------
-        InstallationError str
-          -> "Installation error: " <> str
-
-        UsageError str -- should never happen
-          -> unlines ["Unexpected usage error", str]
-
-        CmdLineError str
-          -> unlines ["Unexpected usage error", str]
-
-        ProgramError str
-            -> "Program error: " <> str
-        PprProgramError str  sdoc  ->
-            unlines ["Program error:", str,""
-                    , Out.showSDoc dflags sdoc]
-  where
-    requestReport = "Please report this bug to the compiler authors."
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+module Development.IDE.GHC.Error+  (+    -- * Producing Diagnostic values+    diagFromErrMsgs+  , diagFromErrMsg+  , diagFromString+  , diagFromStrings+  , diagFromGhcException+  , catchSrcErrors++  -- * utilities working with spans+  , srcSpanToLocation+  , srcSpanToRange+  , realSrcSpanToRange+  , realSrcLocToPosition+  , srcSpanToFilename+  , zeroSpan+  , realSpan+  , isInsideSrcSpan+  , noSpan++  -- * utilities working with severities+  , toDSeverity+  ) where++import                     Development.IDE.Types.Diagnostics as D+import qualified           Data.Text as T+import Data.Maybe+import Development.IDE.Types.Location+import Development.IDE.GHC.Orphans()+import qualified FastString as FS+import           GHC+import           Bag+import HscTypes+import Panic+import           ErrUtils+import           SrcLoc+import qualified Outputable                 as Out++++diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,)+    Diagnostic+    { _range    = fromMaybe noRange $ srcSpanToRange loc+    , _severity = Just sev+    , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers+    , _message  = msg+    , _code     = Nothing+    , _relatedInformation = Nothing+    , _tags     = Nothing+    }++-- | Produce a GHC-style error from a source span and a message.+diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]+diagFromErrMsg diagSource dflags e =+    [ diagFromText diagSource sev (errMsgSpan e)+      $ T.pack $ formatErrorWithQual dflags e+    | Just sev <- [toDSeverity $ errMsgSeverity e]]++formatErrorWithQual :: DynFlags -> ErrMsg -> String+formatErrorWithQual dflags e =+    Out.showSDoc dflags+    $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e)+    $ ErrUtils.formatErrDoc dflags+    $ ErrUtils.errMsgDoc e++diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]+diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList++-- | Convert a GHC SrcSpan to a DAML compiler Range+srcSpanToRange :: SrcSpan -> Maybe Range+srcSpanToRange (UnhelpfulSpan _)  = Nothing+srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real++realSrcSpanToRange :: RealSrcSpan -> Range+realSrcSpanToRange real =+  Range (realSrcLocToPosition $ realSrcSpanStart real)+        (realSrcLocToPosition $ realSrcSpanEnd   real)++realSrcLocToPosition :: RealSrcLoc -> Position+realSrcLocToPosition real =+  Position (srcLocLine real - 1) (srcLocCol real - 1)++-- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones)+-- FIXME This may not be an _absolute_ file name, needs fixing.+srcSpanToFilename :: SrcSpan -> Maybe FilePath+srcSpanToFilename (UnhelpfulSpan _) = Nothing+srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real++srcSpanToLocation :: SrcSpan -> Maybe Location+srcSpanToLocation src = do+  fs <- srcSpanToFilename src+  rng <- srcSpanToRange src+  -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code+  pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng++isInsideSrcSpan :: Position -> SrcSpan -> Bool+p `isInsideSrcSpan` r = case srcSpanToRange r of+  Just (Range sp ep) -> sp <= p && p <= ep+  _ -> False++-- | Convert a GHC severity to a DAML compiler Severity. Severities below+-- "Warning" level are dropped (returning Nothing).+toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity+toDSeverity SevOutput      = Nothing+toDSeverity SevInteractive = Nothing+toDSeverity SevDump        = Nothing+toDSeverity SevInfo        = Just DsInfo+toDSeverity SevWarning     = Just DsWarning+toDSeverity SevError       = Just DsError+toDSeverity SevFatal       = Just DsError+++-- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given+--   (optional) locations and message strings.+diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic]+diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev))++-- | Produce a GHC-style error from a source span and a message.+diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic]+diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x]+++-- | Produces an "unhelpful" source span with the given string.+noSpan :: String -> SrcSpan+noSpan = UnhelpfulSpan . FS.fsLit+++-- | creates a span with zero length in the filename of the argument passed+zeroSpan :: FS.FastString -- ^ file path of span+         -> RealSrcSpan+zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1)++realSpan :: SrcSpan+         -> Maybe RealSrcSpan+realSpan = \case+  RealSrcSpan r -> Just r+  UnhelpfulSpan _ -> Nothing+++-- | Catch the errors thrown by GHC (SourceErrors and+-- compiler-internal exceptions like Panic or InstallationError), and turn them into+-- diagnostics+catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a)+catchSrcErrors dflags fromWhere ghcM = do+    handleGhcException (ghcExceptionToDiagnostics dflags) $+      handleSourceError (sourceErrorToDiagnostics dflags) $+      Right <$> ghcM+    where+        ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags+        sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages+++diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]+diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)++showGHCE :: DynFlags -> GhcException -> String+showGHCE dflags exc = case exc of+        Signal n+          -> "Signal: " <> show n++        Panic s+          -> unwords ["Compilation Issue:", s, "\n", requestReport]+        PprPanic  s sdoc+          -> unlines ["Compilation Issue", s,""+                     , Out.showSDoc dflags sdoc+                     , requestReport ]++        Sorry s+          -> "Unsupported feature: " <> s+        PprSorry s sdoc+          -> unlines ["Unsupported feature: ", s,""+                     , Out.showSDoc dflags sdoc]+++        ---------- errors below should not happen at all --------+        InstallationError str+          -> "Installation error: " <> str++        UsageError str -- should never happen+          -> unlines ["Unexpected usage error", str]++        CmdLineError str+          -> unlines ["Unexpected usage error", str]++        ProgramError str+            -> "Program error: " <> str+        PprProgramError str  sdoc  ->+            unlines ["Program error:", str,""+                    , Out.showSDoc dflags sdoc]+  where+    requestReport = "Please report this bug to the compiler authors."
+ src/Development/IDE/GHC/ExactPrint.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Development.IDE.GHC.ExactPrint+    ( Graft(..),+      graft,+      graftDecls,+      graftDeclsWithM,+      hoistGraft,+      graftWithM,+      graftWithSmallestM,+      transform,+      transformM,+      useAnnotatedSource,+      annotateParsedSource,+      ASTElement (..),+      ExceptStringT (..),+    )+where++import BasicTypes (appPrec)+import Control.Applicative (Alternative)+import Control.Monad+import qualified Control.Monad.Fail as Fail+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Zip+import qualified Data.DList as DL+import Data.Either.Extra (mapLeft)+import Data.Functor.Classes+import Data.Functor.Contravariant+import qualified Data.Text as T+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Rules+import Development.IDE.Core.Shake+import Development.IDE.GHC.Compat hiding (parseExpr)+import Development.IDE.Types.Location+import Generics.SYB+import Ide.PluginUtils+import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.Parsers+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities)+import Outputable (Outputable, ppr, showSDoc)+import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType)+#if __GLASGOW_HASKELL__ == 808+import Control.Arrow+#endif+++------------------------------------------------------------------------------++-- | Get the latest version of the annotated parse source.+useAnnotatedSource ::+    String ->+    IdeState ->+    NormalizedFilePath ->+    IO (Maybe (Annotated ParsedSource))+useAnnotatedSource herald state nfp =+    fmap annotateParsedSource+        <$> runAction herald state (use GetParsedModule nfp)++annotateParsedSource :: ParsedModule -> Annotated ParsedSource+annotateParsedSource = fixAnns++------------------------------------------------------------------------------++{- | A transformation for grafting source trees together. Use the semigroup+ instance to combine 'Graft's, and run them via 'transform'.+-}+newtype Graft m a = Graft+    { runGraft :: DynFlags -> a -> TransformT m a+    }++hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a+hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f)++newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a}+    deriving newtype+        ( MonadTrans+        , Monad+        , Functor+        , Applicative+        , Alternative+        , Foldable+        , Contravariant+        , MonadIO+        , Eq1+        , Ord1+        , Show1+        , Read1+        , MonadZip+        , MonadPlus+        , Eq+        , Ord+        , Show+        , Read+        )++instance Monad m => Fail.MonadFail (ExceptStringT m) where+    fail = ExceptStringT . ExceptT . pure . Left++instance Monad m => Semigroup (Graft m a) where+    Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags++instance Monad m => Monoid (Graft m a) where+    mempty = Graft $ const pure++------------------------------------------------------------------------------++-- | Convert a 'Graft' into a 'WorkspaceEdit'.+transform ::+    DynFlags ->+    ClientCapabilities ->+    Uri ->+    Graft (Either String) ParsedSource ->+    Annotated ParsedSource ->+    Either String WorkspaceEdit+transform dflags ccs uri f a = do+    let src = printA a+    a' <- transformA a $ runGraft f dflags+    let res = printA a'+    pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions++------------------------------------------------------------------------------++-- | Convert a 'Graft' into a 'WorkspaceEdit'.+transformM ::+    Monad m =>+    DynFlags ->+    ClientCapabilities ->+    Uri ->+    Graft (ExceptStringT m) ParsedSource ->+    Annotated ParsedSource ->+    m (Either String WorkspaceEdit)+transformM dflags ccs uri f a = runExceptT $+    runExceptString $ do+        let src = printA a+        a' <- transformA a $ runGraft f dflags+        let res = printA a'+        pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions++------------------------------------------------------------------------------++{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the+ given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or+ this is a no-op.+-}+graft ::+    forall ast a.+    (Data a, ASTElement ast) =>+    SrcSpan ->+    Located ast ->+    Graft (Either String) a+graft dst val = Graft $ \dflags a -> do+    (anns, val') <- annotate dflags $ maybeParensAST val+    modifyAnnsT $ mappend anns+    pure $+        everywhere'+            ( mkT $+                \case+                    (L src _ :: Located ast) | src == dst -> val'+                    l -> l+            )+            a++------------------------------------------------------------------------------++graftWithM ::+    forall ast m a.+    (Fail.MonadFail m, Data a, ASTElement ast) =>+    SrcSpan ->+    (Located ast -> TransformT m (Maybe (Located ast))) ->+    Graft m a+graftWithM dst trans = Graft $ \dflags a -> do+    everywhereM'+        ( mkM $+            \case+                val@(L src _ :: Located ast)+                    | src == dst -> do+                        mval <- trans val+                        case mval of+                            Just val' -> do+                                (anns, val'') <-+                                    hoistTransform (either Fail.fail pure) $+                                        annotate dflags $ maybeParensAST val'+                                modifyAnnsT $ mappend anns+                                pure val''+                            Nothing -> pure val+                l -> pure l+        )+        a++graftWithSmallestM ::+    forall ast m a.+    (Fail.MonadFail m, Data a, ASTElement ast) =>+    SrcSpan ->+    (Located ast -> TransformT m (Maybe (Located ast))) ->+    Graft m a+graftWithSmallestM dst trans = Graft $ \dflags a -> do+    everywhereM'+        ( mkM $+            \case+                val@(L src _ :: Located ast)+                    | dst `isSubspanOf` src -> do+                        mval <- trans val+                        case mval of+                            Just val' -> do+                                (anns, val'') <-+                                    hoistTransform (either Fail.fail pure) $+                                        annotate dflags $ maybeParensAST val'+                                modifyAnnsT $ mappend anns+                                pure val''+                            Nothing -> pure val+                l -> pure l+        )+        a++graftDecls ::+    forall a.+    (HasDecls a) =>+    SrcSpan ->+    [LHsDecl GhcPs] ->+    Graft (Either String) a+graftDecls dst decs0 = Graft $ \dflags a -> do+    decs <- forM decs0 $ \decl -> do+        (anns, decl') <- annotateDecl dflags decl+        modifyAnnsT $ mappend anns+        pure decl'+    let go [] = DL.empty+        go (L src e : rest)+            | src == dst = DL.fromList decs <> DL.fromList rest+            | otherwise = DL.singleton (L src e) <> go rest+    modifyDeclsT (pure . DL.toList . go) a++graftDeclsWithM ::+    forall a m.+    (HasDecls a, Fail.MonadFail m) =>+    SrcSpan ->+    (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) ->+    Graft m a+graftDeclsWithM dst toDecls = Graft $ \dflags a -> do+    let go [] = pure DL.empty+        go (e@(L src _) : rest)+            | src == dst = toDecls e >>= \case+                Just decs0 -> do+                    decs <- forM decs0 $ \decl -> do+                        (anns, decl') <-+                            hoistTransform (either Fail.fail pure) $+                            annotateDecl dflags decl+                        modifyAnnsT $ mappend anns+                        pure decl'+                    pure $ DL.fromList decs <> DL.fromList rest+                Nothing -> (DL.singleton e <>) <$> go rest+            | otherwise = (DL.singleton e <>) <$> go rest+    modifyDeclsT (fmap DL.toList . go) a+++everywhereM' :: forall m. Monad m => GenericM m -> GenericM m+everywhereM' f = go+    where+        go :: GenericM m+        go = gmapM go <=< f++class (Data ast, Outputable ast) => ASTElement ast where+    parseAST :: Parser (Located ast)+    maybeParensAST :: Located ast -> Located ast++instance p ~ GhcPs => ASTElement (HsExpr p) where+    parseAST = parseExpr+    maybeParensAST = parenthesize++instance p ~ GhcPs => ASTElement (Pat p) where+#if __GLASGOW_HASKELL__ == 808+    parseAST = fmap (fmap $ right $ second dL) . parsePattern+    maybeParensAST = dL . parenthesizePat appPrec . unLoc+#else+    parseAST = parsePattern+    maybeParensAST = parenthesizePat appPrec+#endif++instance p ~ GhcPs => ASTElement (HsType p) where+    parseAST = parseType+    maybeParensAST = parenthesizeHsType appPrec++instance p ~ GhcPs => ASTElement (HsDecl p) where+    parseAST = parseDecl+    maybeParensAST = id++------------------------------------------------------------------------------++-- | Dark magic I stole from retrie. No idea what it does.+fixAnns :: ParsedModule -> Annotated ParsedSource+fixAnns ParsedModule {..} =+    let ranns = relativiseApiAnns pm_parsed_source pm_annotations+     in unsafeMkA pm_parsed_source ranns 0++------------------------------------------------------------------------------++-- | Given an 'LHSExpr', compute its exactprint annotations.+annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast)+annotate dflags ast = do+    uniq <- show <$> uniqueSrcSpanT+    let rendered = render dflags ast+    (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered+    let anns' = setPrecedingLines expr' 0 1 anns+    pure (anns', expr')++-- | Given an 'LHsDecl', compute its exactprint annotations.+annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs)+annotateDecl dflags ast = do+    uniq <- show <$> uniqueSrcSpanT+    let rendered = render dflags ast+    (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered+    let anns' = setPrecedingLines expr' 1 0 anns+    pure (anns', expr')+------------------------------------------------------------------------------++-- | Print out something 'Outputable'.+render :: Outputable a => DynFlags -> a -> String+render dflags = showSDoc dflags . ppr++------------------------------------------------------------------------------++-- | Put parentheses around an expression if required.+parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs+parenthesize = parenthesizeHsExpr appPrec
src/Development/IDE/GHC/Orphans.hs view
@@ -1,112 +1,146 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-#include "ghc-api-version.h"
-
--- | Orphan instances for GHC.
---   Note that the 'NFData' instances may not be law abiding.
-module Development.IDE.GHC.Orphans() where
-
-import           Bag
-import           Control.DeepSeq
-import           Data.Hashable
-import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Util
-import           GHC                        ()
-import           GhcPlugins
-import qualified StringBuffer               as SB
-
-
--- Orphan instances for types from the GHC API.
-instance Show CoreModule where show = prettyPrint
-instance NFData CoreModule where rnf = rwhnf
-instance Show CgGuts where show = prettyPrint . cg_module
-instance NFData CgGuts where rnf = rwhnf
-instance Show ModDetails where show = const "<moddetails>"
-instance NFData ModDetails where rnf = rwhnf
-instance NFData SafeHaskellMode where rnf = rwhnf
-instance Show Linkable where show = prettyPrint
-instance NFData Linkable where rnf = rwhnf
-instance Show PackageFlag where show = prettyPrint
-instance Show InteractiveImport where show = prettyPrint
-instance Show ComponentId  where show = prettyPrint
-instance Show PackageName  where show = prettyPrint
-instance Show SourcePackageId  where show = prettyPrint
-
-instance Show InstalledUnitId where
-    show = installedUnitIdString
-
-instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
-
-instance NFData SB.StringBuffer where rnf = rwhnf
-
-instance Show Module where
-    show = moduleNameString . moduleName
-
-instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint
-
-instance (NFData l, NFData e) => NFData (GenLocated l e) where
-    rnf (L l e) = rnf l `seq` rnf e
-
-instance Show ModSummary where
-    show = show . ms_mod
-
-instance Show ParsedModule where
-    show = show . pm_mod_summary
-
-instance NFData ModSummary where
-    rnf = rwhnf
-
-#if !MIN_GHC_API_VERSION(8,10,0)
-instance NFData FastString where
-    rnf = rwhnf
-#endif
-
-instance NFData ParsedModule where
-    rnf = rwhnf
-
-instance Hashable InstalledUnitId where
-  hashWithSalt salt = hashWithSalt salt . installedUnitIdString
-
-instance Show HieFile where
-    show = show . hie_module
-
-instance NFData HieFile where
-    rnf = rwhnf
-
-deriving instance Eq SourceModified
-deriving instance Show SourceModified
-instance NFData SourceModified where
-    rnf = rwhnf
-
-instance Show ModuleName where
-    show = moduleNameString
-instance Hashable ModuleName where
-    hashWithSalt salt = hashWithSalt salt . show
-
-
-instance NFData a => NFData (IdentifierDetails a) where
-    rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b)
-
-instance NFData RealSrcSpan where
-    rnf = rwhnf
-
-instance NFData Type where
-    rnf = rwhnf
-
-instance Show a => Show (Bag a) where
-    show = show . bagToList
-
-instance NFData HsDocString where
-    rnf = rwhnf
-
-instance Show ModGuts where
-    show _ = "modguts"
-instance NFData ModGuts where
-    rnf = rwhnf
-
-instance NFData (ImportDecl GhcPs) where
-    rnf = rwhnf
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+#include "ghc-api-version.h"++-- | Orphan instances for GHC.+--   Note that the 'NFData' instances may not be law abiding.+module Development.IDE.GHC.Orphans() where++import           Bag+import           Control.DeepSeq+import Data.Aeson+import           Data.Hashable+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Util+import           GHC                        ()+import           GhcPlugins+import qualified StringBuffer               as SB+import Data.Text (Text)+import Data.String (IsString(fromString))+++-- Orphan instances for types from the GHC API.+instance Show CoreModule where show = prettyPrint+instance NFData CoreModule where rnf = rwhnf+instance Show CgGuts where show = prettyPrint . cg_module+instance NFData CgGuts where rnf = rwhnf+instance Show ModDetails where show = const "<moddetails>"+instance NFData ModDetails where rnf = rwhnf+instance NFData SafeHaskellMode where rnf = rwhnf+instance Show Linkable where show = prettyPrint+instance NFData Linkable where rnf = rwhnf+instance Show PackageFlag where show = prettyPrint+instance Show InteractiveImport where show = prettyPrint+instance Show ComponentId  where show = prettyPrint+instance Show PackageName  where show = prettyPrint+instance Show SourcePackageId  where show = prettyPrint++instance Show InstalledUnitId where+    show = installedUnitIdString++instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS++instance NFData SB.StringBuffer where rnf = rwhnf++instance Show Module where+    show = moduleNameString . moduleName++instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint++instance (NFData l, NFData e) => NFData (GenLocated l e) where+    rnf (L l e) = rnf l `seq` rnf e++instance Show ModSummary where+    show = show . ms_mod++instance Show ParsedModule where+    show = show . pm_mod_summary++instance NFData ModSummary where+    rnf = rwhnf++#if !MIN_GHC_API_VERSION(8,10,0)+instance NFData FastString where+    rnf = rwhnf+#endif++instance NFData ParsedModule where+    rnf = rwhnf++instance Hashable InstalledUnitId where+  hashWithSalt salt = hashWithSalt salt . installedUnitIdString++instance Show HieFile where+    show = show . hie_module++instance NFData HieFile where+    rnf = rwhnf++deriving instance Eq SourceModified+deriving instance Show SourceModified+instance NFData SourceModified where+    rnf = rwhnf++instance Show ModuleName where+    show = moduleNameString+instance Hashable ModuleName where+    hashWithSalt salt = hashWithSalt salt . show+++instance NFData a => NFData (IdentifierDetails a) where+    rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b)++instance NFData RealSrcSpan where+    rnf = rwhnf++srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,+    srcSpanEndLineTag, srcSpanEndColTag :: Text+srcSpanFileTag = "srcSpanFile"+srcSpanStartLineTag = "srcSpanStartLine"+srcSpanStartColTag = "srcSpanStartCol"+srcSpanEndLineTag = "srcSpanEndLine"+srcSpanEndColTag = "srcSpanEndCol"++instance ToJSON RealSrcSpan where+  toJSON spn =+      object+        [ srcSpanFileTag .= unpackFS (srcSpanFile spn)+        , srcSpanStartLineTag .= srcSpanStartLine spn+        , srcSpanStartColTag .= srcSpanStartCol spn+        , srcSpanEndLineTag .= srcSpanEndLine spn+        , srcSpanEndColTag .= srcSpanEndCol spn+        ]++instance FromJSON RealSrcSpan where+  parseJSON = withObject "object" $ \obj -> do+      file <- fromString <$> (obj .: srcSpanFileTag)+      mkRealSrcSpan+        <$> (mkRealSrcLoc file+                <$> obj .: srcSpanStartLineTag+                <*> obj .: srcSpanStartColTag+            )+        <*> (mkRealSrcLoc file+                <$> obj .: srcSpanEndLineTag+                <*> obj .: srcSpanEndColTag+            )++instance NFData Type where+    rnf = rwhnf++instance Show a => Show (Bag a) where+    show = show . bagToList++instance NFData HsDocString where+    rnf = rwhnf++instance Show ModGuts where+    show _ = "modguts"+instance NFData ModGuts where+    rnf = rwhnf++instance NFData (ImportDecl GhcPs) where+    rnf = rwhnf
src/Development/IDE/GHC/Util.hs view
@@ -1,336 +1,336 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- | General utility functions, mostly focused around GHC operations.
-module Development.IDE.GHC.Util(
-    -- * HcsEnv and environment
-    HscEnvEq,
-    hscEnv, newHscEnvEq,
-    hscEnvWithImportPaths,
-    envImportPaths,
-    modifyDynFlags,
-    evalGhcEnv,
-    deps,
-    -- * GHC wrappers
-    prettyPrint,
-    printRdrName,
-    printName,
-    ParseResult(..), runParser,
-    lookupPackageConfig,
-    textToStringBuffer,
-    bytestringToStringBuffer,
-    stringBufferToByteString,
-    moduleImportPath,
-    cgGutsToCoreModule,
-    fingerprintToBS,
-    fingerprintFromStringBuffer,
-    -- * General utilities
-    readFileUtf8,
-    hDuplicateTo',
-    setHieDir,
-    dontWriteHieFiles,
-    disableWarningsAsErrors,
-    newHscEnvEqPreserveImportPaths,
-    newHscEnvEqWithImportPaths) where
-
-import Control.Concurrent
-import Data.List.Extra
-import Data.ByteString.Internal (ByteString(..))
-import Data.Maybe
-import Data.Typeable
-import qualified Data.ByteString.Internal as BS
-import Fingerprint
-import GhcMonad
-import Control.Exception
-import Data.IORef
-import FileCleanup
-import Foreign.Ptr
-import Foreign.ForeignPtr
-import Foreign.Storable
-import GHC.IO.BufferedIO (BufferedIO)
-import GHC.IO.Device as IODevice
-import GHC.IO.Encoding
-import GHC.IO.Exception
-import GHC.IO.Handle.Types
-import GHC.IO.Handle.Internals
-import Data.Unique
-import Development.Shake.Classes
-import qualified Data.Text                as T
-import qualified Data.Text.Encoding       as T
-import qualified Data.Text.Encoding.Error as T
-import qualified Data.ByteString          as BS
-import Lexer
-import StringBuffer
-import System.FilePath
-import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
-import PackageConfig (PackageConfig)
-import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
-import Packages (getPackageConfigMap, lookupPackage')
-import SrcLoc (mkRealSrcLoc)
-import FastString (mkFastString)
-import Module (moduleNameSlashes, InstalledUnitId)
-import OccName (parenSymOcc)
-import RdrName (nameRdrName, rdrNameOcc)
-
-import Development.IDE.GHC.Compat as GHC
-import Development.IDE.Types.Location
-import System.Directory (canonicalizePath)
-
-
-----------------------------------------------------------------------
--- GHC setup
-
--- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',
---   since that function also reloads packages (which is very slow).
-modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
-modifyDynFlags f = do
-  newFlags <- f <$> getSessionDynFlags
-  -- We do not use setSessionDynFlags here since we handle package
-  -- initialization separately.
-  modifySession $ \h ->
-    h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
-
--- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.
-lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
-lookupPackageConfig unitId env =
-    lookupPackage' False pkgConfigMap unitId
-    where
-        pkgConfigMap =
-            -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap
-            -- from PackageState so we have to wrap it in DynFlags first.
-            getPackageConfigMap $ hsc_dflags env
-
-
--- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.
---   Currently implemented somewhat inefficiently (if it ever comes up in a profile).
-textToStringBuffer :: T.Text -> StringBuffer
-textToStringBuffer = stringToStringBuffer . T.unpack
-
-runParser :: DynFlags -> String -> P a -> ParseResult a
-runParser flags str parser = unP parser parseState
-    where
-      filename = "<interactive>"
-      location = mkRealSrcLoc (mkFastString filename) 1 1
-      buffer = stringToStringBuffer str
-      parseState = mkPState flags buffer location
-
-stringBufferToByteString :: StringBuffer -> ByteString
-stringBufferToByteString StringBuffer{..} = PS buf cur len
-
-bytestringToStringBuffer :: ByteString -> StringBuffer
-bytestringToStringBuffer (PS buf cur len) = StringBuffer{..}
-
--- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
-prettyPrint :: Outputable a => a -> String
-prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
-
--- | Pretty print a 'RdrName' wrapping operators in parens
-printRdrName :: RdrName -> String
-printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)
-  where
-    rn = rdrNameOcc name
-
--- | Pretty print a 'Name' wrapping operators in parens
-printName :: Name -> String
-printName = printRdrName . nameRdrName
-
--- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
---   pieces, but designed to be more efficient than a standard 'runGhc'.
-evalGhcEnv :: HscEnv -> Ghc b -> IO b
-evalGhcEnv env act = snd <$> runGhcEnv env act
-
--- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
---   pieces, but designed to be more efficient than a standard 'runGhc'.
-runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
-runGhcEnv env act = do
-    filesToClean <- newIORef emptyFilesToClean
-    dirsToClean <- newIORef mempty
-    let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
-    ref <- newIORef env{hsc_dflags=dflags}
-    res <- unGhc act (Session ref) `finally` do
-        cleanTempFiles dflags
-        cleanTempDirs dflags
-    (,res) <$> readIORef ref
-
--- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
---   For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
---   @\/usr\/Test@ should be on the include path to find sibling modules.
-moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
--- The call to takeDirectory is required since DAML does not require that
--- the file name matches the module name in the last component.
--- Once that has changed we can get rid of this.
-moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
-    -- This happens for single-component modules since takeDirectory "A" == "."
-    | modDir == "." = Just pathDir
-    | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
-  where
-    -- A for module A.B
-    modDir =
-        takeDirectory $
-        fromNormalizedFilePath $ toNormalizedFilePath' $
-        moduleNameSlashes mn
-
--- | An 'HscEnv' with equality. Two values are considered equal
---   if they are created with the same call to 'newHscEnvEq'.
-data HscEnvEq = HscEnvEq
-    { envUnique :: !Unique
-    , hscEnv :: !HscEnv
-    , deps   :: [(InstalledUnitId, DynFlags)]
-               -- ^ In memory components for this HscEnv
-               -- This is only used at the moment for the import dirs in
-               -- the DynFlags
-    , envImportPaths :: Maybe [String]
-        -- ^ If Just, import dirs originally configured in this env
-        --   If Nothing, the env import dirs are unaltered
-    }
-
--- | Wrap an 'HscEnv' into an 'HscEnvEq'.
-newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEq cradlePath hscEnv0 deps = do
-    envUnique <- newUnique
-    let relativeToCradle = (takeDirectory cradlePath </>)
-        hscEnv = removeImportPaths hscEnv0
-
-    -- Canonicalize import paths since we also canonicalize targets
-    importPathsCanon <-
-      mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
-    let envImportPaths = Just importPathsCanon
-
-    return HscEnvEq{..}
-
-newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
-    envUnique <- newUnique
-    return HscEnvEq{..}
-
--- | Wrap an 'HscEnv' into an 'HscEnvEq'.
-newHscEnvEqPreserveImportPaths
-    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEqPreserveImportPaths hscEnv deps = do
-    let envImportPaths = Nothing
-    envUnique <- newUnique
-    return HscEnvEq{..}
-
--- | Unwrap the 'HscEnv' with the original import paths.
---   Used only for locating imports
-hscEnvWithImportPaths :: HscEnvEq -> HscEnv
-hscEnvWithImportPaths HscEnvEq{..}
-    | Just imps <- envImportPaths
-    = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}}
-    | otherwise
-    = hscEnv
-
-removeImportPaths :: HscEnv -> HscEnv
-removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}}
-
-instance Show HscEnvEq where
-  show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique)
-
-instance Eq HscEnvEq where
-  a == b = envUnique a == envUnique b
-
-instance NFData HscEnvEq where
-  rnf (HscEnvEq a b c d) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d
-
-instance Hashable HscEnvEq where
-  hashWithSalt s = hashWithSalt s . envUnique
-
--- Fake instance needed to persuade Shake to accept this type as a key.
--- No harm done as ghcide never persists these keys currently
-instance Binary HscEnvEq where
-  put _ = error "not really"
-  get = error "not really"
-
--- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
-readFileUtf8 :: FilePath -> IO T.Text
-readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
-
--- | Convert from a 'CgGuts' to a 'CoreModule'.
-cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
-cgGutsToCoreModule safeMode guts modDetails = CoreModule
-    (cg_module guts)
-    (md_types modDetails)
-    (cg_binds guts)
-    safeMode
-
--- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
---   Will produce an 8 byte unreadable ByteString.
-fingerprintToBS :: Fingerprint -> BS.ByteString
-fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
-    ptr <- pure $ castPtr ptr
-    pokeElemOff ptr 0 a
-    pokeElemOff ptr 1 b
-
--- | Take the 'Fingerprint' of a 'StringBuffer'.
-fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
-fingerprintFromStringBuffer (StringBuffer buf len cur) =
-    withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
-
-
--- | A slightly modified version of 'hDuplicateTo' from GHC.
---   Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
-hDuplicateTo' :: Handle -> Handle -> IO ()
-hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
- withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
-   -- The implementation in base has this call to hClose_help.
-   -- _ <- hClose_help h2_
-   -- hClose_help does two things:
-   -- 1. It flushes the buffer, we replicate this here
-   _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure ()
-   -- 2. It closes the handle. This is redundant since dup2 takes care of that
-   -- but even worse it is actively harmful! Once the handle has been closed
-   -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY
-   -- if it happens just in the right moment.
-   withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
-     dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
-hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
- withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
-   _ <- hClose_help w2_
-   withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
-     dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
- withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
-   _ <- hClose_help r2_
-   withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
-     dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
-hDuplicateTo' h1 _ =
-  ioe_dupHandlesNotCompatible h1
-
--- | This is copied unmodified from GHC since it is not exposed.
-dupHandleTo :: FilePath
-            -> Handle
-            -> Maybe (MVar Handle__)
-            -> Handle__
-            -> Handle__
-            -> Maybe HandleFinalizer
-            -> IO Handle__
-dupHandleTo filepath h other_side
-            _hto_@Handle__{haDevice=devTo}
-            h_@Handle__{haDevice=dev} mb_finalizer = do
-  flushBuffer h_
-  case cast devTo of
-    Nothing   -> ioe_dupHandlesNotCompatible h
-    Just dev' -> do
-      _ <- IODevice.dup2 dev dev'
-      FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
-      takeMVar m
-
--- | This is copied unmodified from GHC since it is not exposed.
--- Note the beautiful inline comment!
-dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
-           -> FilePath
-           -> Maybe (MVar Handle__)
-           -> Handle__
-           -> Maybe HandleFinalizer
-           -> IO Handle
-dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do
-   -- XXX wrong!
-  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
-  mkHandle new_dev filepath haType True{-buffered-} mb_codec
-      NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
-      mb_finalizer other_side
-
--- | This is copied unmodified from GHC since it is not exposed.
-ioe_dupHandlesNotCompatible :: Handle -> IO a
-ioe_dupHandlesNotCompatible h =
-   ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
-                "handles are incompatible" Nothing Nothing)
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- | General utility functions, mostly focused around GHC operations.+module Development.IDE.GHC.Util(+    -- * HcsEnv and environment+    HscEnvEq,+    hscEnv, newHscEnvEq,+    hscEnvWithImportPaths,+    envImportPaths,+    modifyDynFlags,+    evalGhcEnv,+    deps,+    -- * GHC wrappers+    prettyPrint,+    printRdrName,+    printName,+    ParseResult(..), runParser,+    lookupPackageConfig,+    textToStringBuffer,+    bytestringToStringBuffer,+    stringBufferToByteString,+    moduleImportPath,+    cgGutsToCoreModule,+    fingerprintToBS,+    fingerprintFromStringBuffer,+    -- * General utilities+    readFileUtf8,+    hDuplicateTo',+    setHieDir,+    dontWriteHieFiles,+    disableWarningsAsErrors,+    newHscEnvEqPreserveImportPaths,+    newHscEnvEqWithImportPaths) where++import Control.Concurrent+import Data.List.Extra+import Data.ByteString.Internal (ByteString(..))+import Data.Maybe+import Data.Typeable+import qualified Data.ByteString.Internal as BS+import Fingerprint+import GhcMonad+import Control.Exception+import Data.IORef+import FileCleanup+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable+import GHC.IO.BufferedIO (BufferedIO)+import GHC.IO.Device as IODevice+import GHC.IO.Encoding+import GHC.IO.Exception+import GHC.IO.Handle.Types+import GHC.IO.Handle.Internals+import Data.Unique+import Development.Shake.Classes+import qualified Data.Text                as T+import qualified Data.Text.Encoding       as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.ByteString          as BS+import Lexer+import StringBuffer+import System.FilePath+import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))+import PackageConfig (PackageConfig)+import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)+import Packages (getPackageConfigMap, lookupPackage')+import SrcLoc (mkRealSrcLoc)+import FastString (mkFastString)+import Module (moduleNameSlashes, InstalledUnitId)+import OccName (parenSymOcc)+import RdrName (nameRdrName, rdrNameOcc)++import Development.IDE.GHC.Compat as GHC+import Development.IDE.Types.Location+import System.Directory (canonicalizePath)+++----------------------------------------------------------------------+-- GHC setup++-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',+--   since that function also reloads packages (which is very slow).+modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()+modifyDynFlags f = do+  newFlags <- f <$> getSessionDynFlags+  -- We do not use setSessionDynFlags here since we handle package+  -- initialization separately.+  modifySession $ \h ->+    h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }++-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.+lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig+lookupPackageConfig unitId env =+    lookupPackage' False pkgConfigMap unitId+    where+        pkgConfigMap =+            -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap+            -- from PackageState so we have to wrap it in DynFlags first.+            getPackageConfigMap $ hsc_dflags env+++-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.+--   Currently implemented somewhat inefficiently (if it ever comes up in a profile).+textToStringBuffer :: T.Text -> StringBuffer+textToStringBuffer = stringToStringBuffer . T.unpack++runParser :: DynFlags -> String -> P a -> ParseResult a+runParser flags str parser = unP parser parseState+    where+      filename = "<interactive>"+      location = mkRealSrcLoc (mkFastString filename) 1 1+      buffer = stringToStringBuffer str+      parseState = mkPState flags buffer location++stringBufferToByteString :: StringBuffer -> ByteString+stringBufferToByteString StringBuffer{..} = PS buf cur len++bytestringToStringBuffer :: ByteString -> StringBuffer+bytestringToStringBuffer (PS buf cur len) = StringBuffer{..}++-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.+prettyPrint :: Outputable a => a -> String+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr++-- | Pretty print a 'RdrName' wrapping operators in parens+printRdrName :: RdrName -> String+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)+  where+    rn = rdrNameOcc name++-- | Pretty print a 'Name' wrapping operators in parens+printName :: Name -> String+printName = printRdrName . nameRdrName++-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required+--   pieces, but designed to be more efficient than a standard 'runGhc'.+evalGhcEnv :: HscEnv -> Ghc b -> IO b+evalGhcEnv env act = snd <$> runGhcEnv env act++-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required+--   pieces, but designed to be more efficient than a standard 'runGhc'.+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)+runGhcEnv env act = do+    filesToClean <- newIORef emptyFilesToClean+    dirsToClean <- newIORef mempty+    let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}+    ref <- newIORef env{hsc_dflags=dflags}+    res <- unGhc act (Session ref) `finally` do+        cleanTempFiles dflags+        cleanTempDirs dflags+    (,res) <$> readIORef ref++-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.+--   For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory+--   @\/usr\/Test@ should be on the include path to find sibling modules.+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath+-- The call to takeDirectory is required since DAML does not require that+-- the file name matches the module name in the last component.+-- Once that has changed we can get rid of this.+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn+    -- This happens for single-component modules since takeDirectory "A" == "."+    | modDir == "." = Just pathDir+    | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir+  where+    -- A for module A.B+    modDir =+        takeDirectory $+        fromNormalizedFilePath $ toNormalizedFilePath' $+        moduleNameSlashes mn++-- | An 'HscEnv' with equality. Two values are considered equal+--   if they are created with the same call to 'newHscEnvEq'.+data HscEnvEq = HscEnvEq+    { envUnique :: !Unique+    , hscEnv :: !HscEnv+    , deps   :: [(InstalledUnitId, DynFlags)]+               -- ^ In memory components for this HscEnv+               -- This is only used at the moment for the import dirs in+               -- the DynFlags+    , envImportPaths :: Maybe [String]+        -- ^ If Just, import dirs originally configured in this env+        --   If Nothing, the env import dirs are unaltered+    }++-- | Wrap an 'HscEnv' into an 'HscEnvEq'.+newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEq cradlePath hscEnv0 deps = do+    envUnique <- newUnique+    let relativeToCradle = (takeDirectory cradlePath </>)+        hscEnv = removeImportPaths hscEnv0++    -- Canonicalize import paths since we also canonicalize targets+    importPathsCanon <-+      mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)+    let envImportPaths = Just importPathsCanon++    return HscEnvEq{..}++newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do+    envUnique <- newUnique+    return HscEnvEq{..}++-- | Wrap an 'HscEnv' into an 'HscEnvEq'.+newHscEnvEqPreserveImportPaths+    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEqPreserveImportPaths hscEnv deps = do+    let envImportPaths = Nothing+    envUnique <- newUnique+    return HscEnvEq{..}++-- | Unwrap the 'HscEnv' with the original import paths.+--   Used only for locating imports+hscEnvWithImportPaths :: HscEnvEq -> HscEnv+hscEnvWithImportPaths HscEnvEq{..}+    | Just imps <- envImportPaths+    = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}}+    | otherwise+    = hscEnv++removeImportPaths :: HscEnv -> HscEnv+removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}}++instance Show HscEnvEq where+  show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique)++instance Eq HscEnvEq where+  a == b = envUnique a == envUnique b++instance NFData HscEnvEq where+  rnf (HscEnvEq a b c d) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d++instance Hashable HscEnvEq where+  hashWithSalt s = hashWithSalt s . envUnique++-- Fake instance needed to persuade Shake to accept this type as a key.+-- No harm done as ghcide never persists these keys currently+instance Binary HscEnvEq where+  put _ = error "not really"+  get = error "not really"++-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.+readFileUtf8 :: FilePath -> IO T.Text+readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f++-- | Convert from a 'CgGuts' to a 'CoreModule'.+cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule+cgGutsToCoreModule safeMode guts modDetails = CoreModule+    (cg_module guts)+    (md_types modDetails)+    (cg_binds guts)+    safeMode++-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.+--   Will produce an 8 byte unreadable ByteString.+fingerprintToBS :: Fingerprint -> BS.ByteString+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do+    ptr <- pure $ castPtr ptr+    pokeElemOff ptr 0 a+    pokeElemOff ptr 1 b++-- | Take the 'Fingerprint' of a 'StringBuffer'.+fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint+fingerprintFromStringBuffer (StringBuffer buf len cur) =+    withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len+++-- | A slightly modified version of 'hDuplicateTo' from GHC.+--   Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.+hDuplicateTo' :: Handle -> Handle -> IO ()+hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do+   -- The implementation in base has this call to hClose_help.+   -- _ <- hClose_help h2_+   -- hClose_help does two things:+   -- 1. It flushes the buffer, we replicate this here+   _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure ()+   -- 2. It closes the handle. This is redundant since dup2 takes care of that+   -- but even worse it is actively harmful! Once the handle has been closed+   -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY+   -- if it happens just in the right moment.+   withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do+     dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)+hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do+ withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do+   _ <- hClose_help w2_+   withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do+     dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)+ withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do+   _ <- hClose_help r2_+   withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do+     dupHandleTo path h1 (Just w1) r2_ r1_ Nothing+hDuplicateTo' h1 _ =+  ioe_dupHandlesNotCompatible h1++-- | This is copied unmodified from GHC since it is not exposed.+dupHandleTo :: FilePath+            -> Handle+            -> Maybe (MVar Handle__)+            -> Handle__+            -> Handle__+            -> Maybe HandleFinalizer+            -> IO Handle__+dupHandleTo filepath h other_side+            _hto_@Handle__{haDevice=devTo}+            h_@Handle__{haDevice=dev} mb_finalizer = do+  flushBuffer h_+  case cast devTo of+    Nothing   -> ioe_dupHandlesNotCompatible h+    Just dev' -> do+      _ <- IODevice.dup2 dev dev'+      FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer+      takeMVar m++-- | This is copied unmodified from GHC since it is not exposed.+-- Note the beautiful inline comment!+dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev+           -> FilePath+           -> Maybe (MVar Handle__)+           -> Handle__+           -> Maybe HandleFinalizer+           -> IO Handle+dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do+   -- XXX wrong!+  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing+  mkHandle new_dev filepath haType True{-buffered-} mb_codec+      NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }+      mb_finalizer other_side++-- | This is copied unmodified from GHC since it is not exposed.+ioe_dupHandlesNotCompatible :: Handle -> IO a+ioe_dupHandlesNotCompatible h =+   ioException (IOError (Just h) IllegalOperation "hDuplicateTo"+                "handles are incompatible" Nothing Nothing)
src/Development/IDE/GHC/Warnings.hs view
@@ -1,34 +1,34 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Development.IDE.GHC.Warnings(withWarnings) where
-
-import ErrUtils
-import GhcPlugins as GHC hiding (Var)
-
-import           Control.Concurrent.Extra
-import qualified           Data.Text as T
-
-import           Development.IDE.Types.Diagnostics
-import           Development.IDE.GHC.Error
-
-
--- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some
--- parsed module 'pm@') and produce a "decorated" action that will
--- harvest any warnings encountered executing the action. The 'phase'
--- argument classifies the context (e.g. "Parser", "Typechecker").
---
---   The ModSummary function is required because of
---   https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640
---   which basically says that log_action is taken from the ModSummary when GHC feels like it.
---   The given argument lets you refresh a ModSummary log_action
-withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)
-withWarnings diagSource action = do
-  warnings <- newVar []
-  let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-      newAction dynFlags wr _ loc style msg = do
-        let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg
-        modifyVar_ warnings $ return . (wr_d:)
-  res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}
-  warns <- readVar warnings
-  return (reverse $ concat warns, res)
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.GHC.Warnings(withWarnings) where++import ErrUtils+import GhcPlugins as GHC hiding (Var)++import           Control.Concurrent.Extra+import qualified           Data.Text as T++import           Development.IDE.Types.Diagnostics+import           Development.IDE.GHC.Error+++-- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some+-- parsed module 'pm@') and produce a "decorated" action that will+-- harvest any warnings encountered executing the action. The 'phase'+-- argument classifies the context (e.g. "Parser", "Typechecker").+--+--   The ModSummary function is required because of+--   https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640+--   which basically says that log_action is taken from the ModSummary when GHC feels like it.+--   The given argument lets you refresh a ModSummary log_action+withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)+withWarnings diagSource action = do+  warnings <- newVar []+  let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()+      newAction dynFlags wr _ loc style msg = do+        let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg+        modifyVar_ warnings $ return . (wr_d:)+  res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}}+  warns <- readVar warnings+  return (reverse $ concat warns, res)
src/Development/IDE/Import/DependencyInformation.hs view
@@ -1,403 +1,403 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Development.IDE.Import.DependencyInformation
-  ( DependencyInformation(..)
-  , ModuleImports(..)
-  , RawDependencyInformation(..)
-  , NodeError(..)
-  , ModuleParseError(..)
-  , TransitiveDependencies(..)
-  , FilePathId(..)
-  , NamedModuleDep(..)
-
-  , PathIdMap
-  , emptyPathIdMap
-  , getPathId
-  , lookupPathToId
-  , insertImport
-  , pathToId
-  , idToPath
-  , reachableModules
-  , processDependencyInformation
-  , transitiveDeps
-  , transitiveReverseDependencies
-  , immediateReverseDependencies
-
-  , BootIdMap
-  , insertBootId
-  ) where
-
-import Control.DeepSeq
-import Data.Bifunctor
-import Data.Coerce
-import Data.List
-import Data.Tuple.Extra hiding (first, second)
-import Development.IDE.GHC.Orphans()
-import Data.Either
-import Data.Graph
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HMS
-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.IntMap (IntMap)
-import qualified Data.IntMap.Strict as IntMap
-import qualified Data.IntMap.Lazy as IntMapLazy
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IntSet
-import Data.Maybe
-import Data.Set (Set)
-import qualified Data.Set as Set
-import GHC.Generics (Generic)
-
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Location
-import Development.IDE.Import.FindImports (ArtifactsLocation(..))
-
-import GHC
-import Module
-
--- | The imports for a given module.
-data ModuleImports = ModuleImports
-    { moduleImports :: ![(Located ModuleName, Maybe FilePathId)]
-    -- ^ Imports of a module in the current package and the file path of
-    -- that module on disk (if we found it)
-    , packageImports :: !(Set InstalledUnitId)
-    -- ^ Transitive package dependencies unioned for all imports.
-    } deriving Show
-
--- | For processing dependency information, we need lots of maps and sets of
--- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
--- instead and only convert at the edges.
-newtype FilePathId = FilePathId { getFilePathId :: Int }
-  deriving (Show, NFData, Eq, Ord)
-
--- | Map from 'FilePathId'
-type FilePathIdMap = IntMap
-
--- | Set of 'FilePathId's
-type FilePathIdSet = IntSet
-
-data PathIdMap = PathIdMap
-  { idToPathMap :: !(FilePathIdMap ArtifactsLocation)
-  , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
-  }
-  deriving (Show, Generic)
-
-instance NFData PathIdMap
-
-emptyPathIdMap :: PathIdMap
-emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
-
-getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
-getPathId path m@PathIdMap{..} =
-    case HMS.lookup (artifactFilePath path) pathToIdMap of
-        Nothing ->
-            let !newId = FilePathId $ HMS.size pathToIdMap
-            in (newId, insertPathId path newId m)
-        Just id -> (id, m)
-
-insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
-insertPathId path id PathIdMap{..} =
-    PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)
-
-insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
-insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
-
-pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
-pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
-
-lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
-lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
-
-idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
-idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
-
-idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
-idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
-
-type BootIdMap = FilePathIdMap FilePathId
-
-insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
-insertBootId k = IntMap.insert (getFilePathId k)
-
--- | Unprocessed results that we find by following imports recursively.
-data RawDependencyInformation = RawDependencyInformation
-    { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))
-    , rawPathIdMap :: !PathIdMap
-    -- The rawBootMap maps the FilePathId of a hs-boot file to its
-    -- corresponding hs file. It is used when topologically sorting as we
-    -- need to add edges between .hs-boot and .hs so that the .hs files
-    -- appear later in the sort.
-    , rawBootMap :: !BootIdMap
-    } deriving Show
-
-pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)
-pkgDependencies RawDependencyInformation{..} =
-    IntMap.map (either (const Set.empty) packageImports) rawImports
-
-data DependencyInformation =
-  DependencyInformation
-    { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
-    -- ^ Nodes that cannot be processed correctly.
-    , depModuleNames :: !(FilePathIdMap ShowableModuleName)
-    , depModuleDeps :: !(FilePathIdMap FilePathIdSet)
-    -- ^ For a non-error node, this contains the set of module immediate dependencies
-    -- in the same package.
-    , depReverseModuleDeps :: !(IntMap IntSet)
-    -- ^ Contains a reverse mapping from a module to all those that immediately depend on it.
-    , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))
-    -- ^ For a non-error node, this contains the set of immediate pkg deps.
-    , depPathIdMap :: !PathIdMap
-    -- ^ Map from FilePath to FilePathId
-    , depBootMap :: !BootIdMap
-    -- ^ Map from hs-boot file to the corresponding hs file
-    } deriving (Show, Generic)
-
-newtype ShowableModuleName =
-  ShowableModuleName {showableModuleName :: ModuleName}
-  deriving NFData
-
-instance Show ShowableModuleName where show = moduleNameString . showableModuleName
-
-reachableModules :: DependencyInformation -> [NormalizedFilePath]
-reachableModules DependencyInformation{..} =
-    map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
-
-instance NFData DependencyInformation
-
--- | This does not contain the actual parse error as that is already reported by GetParsedModule.
-data ModuleParseError = ModuleParseError
-  deriving (Show, Generic)
-
-instance NFData ModuleParseError
-
--- | Error when trying to locate a module.
-data LocateError = LocateError [Diagnostic]
-  deriving (Eq, Show, Generic)
-
-instance NFData LocateError
-
--- | An error attached to a node in the dependency graph.
-data NodeError
-  = PartOfCycle (Located ModuleName) [FilePathId]
-  -- ^ This module is part of an import cycle. The module name corresponds
-  -- to the import that enters the cycle starting from this module.
-  -- The list of filepaths represents the elements
-  -- in the cycle in unspecified order.
-  | FailedToLocateImport (Located ModuleName)
-  -- ^ This module has an import that couldn’t be located.
-  | ParseError ModuleParseError
-  | ParentOfErrorNode (Located ModuleName)
-  -- ^ This module is the parent of a module that cannot be
-  -- processed (either it cannot be parsed, is part of a cycle
-  -- or the parent of another error node).
-  deriving (Show, Generic)
-
-instance NFData NodeError where
-  rnf (PartOfCycle m fs) = m `seq` rnf fs
-  rnf (FailedToLocateImport m) = m `seq` ()
-  rnf (ParseError e) = rnf e
-  rnf (ParentOfErrorNode m) = m `seq` ()
-
--- | A processed node in the dependency graph. If there was any error
--- during processing the node or any of its dependencies, this is an
--- `ErrorNode`. Otherwise it is a `SuccessNode`.
-data NodeResult
-  = ErrorNode (NonEmpty NodeError)
-  | SuccessNode [(Located ModuleName, FilePathId)]
-  deriving Show
-
-partitionNodeResults
-    :: [(a, NodeResult)]
-    -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])])
-partitionNodeResults = partitionEithers . map f
-  where f (a, ErrorNode errs) = Left (a, errs)
-        f (a, SuccessNode imps) = Right (a, imps)
-
-instance Semigroup NodeResult where
-   ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs')
-   ErrorNode errs <> SuccessNode _ = ErrorNode errs
-   SuccessNode _ <> ErrorNode errs = ErrorNode errs
-   SuccessNode a <> SuccessNode _ = SuccessNode a
-
-processDependencyInformation :: RawDependencyInformation -> DependencyInformation
-processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
-  DependencyInformation
-    { depErrorNodes = IntMap.fromList errorNodes
-    , depModuleDeps = moduleDeps
-    , depReverseModuleDeps = reverseModuleDeps
-    , depModuleNames = IntMap.fromList $ coerce moduleNames
-    , depPkgDeps = pkgDependencies rawDepInfo
-    , depPathIdMap = rawPathIdMap
-    , depBootMap = rawBootMap
-    }
-  where resultGraph = buildResultGraph rawImports
-        (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
-        moduleNames :: [(FilePathId, ModuleName)]
-        moduleNames =
-          [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
-        successEdges :: [(FilePathId, [FilePathId])]
-        successEdges =
-            map
-              (bimap FilePathId (map snd))
-              successNodes
-        moduleDeps =
-          IntMap.fromList $
-          map (\(FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
-            successEdges
-        reverseModuleDeps =
-          foldr (\(p, cs) res ->
-                                  let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))
-                                  in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges
-
-
--- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
--- 1. Mark each node that is part of an import cycle as an error node.
--- 2. Mark each node that has a parse error as an error node.
--- 3. Mark each node whose immediate children could not be located as an error.
--- 4. Recursively propagate errors to parents if they are not already error nodes.
-buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult
-buildResultGraph g = propagatedErrors
-    where
-        sccs = stronglyConnComp (graphEdges g)
-        (_, cycles) = partitionSCC sccs
-        cycleErrors :: IntMap NodeResult
-        cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles
-        errorsForCycle :: [FilePathId] -> IntMap NodeResult
-        errorsForCycle files =
-          IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files
-        cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]
-        cycleErrorsForFile cycle f =
-          let entryPoints = mapMaybe (findImport f) cycle
-          in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints
-        otherErrors = IntMap.map otherErrorsForFile g
-        otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult
-        otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
-        otherErrorsForFile (Right ModuleImports{moduleImports}) =
-          let toEither (imp, Nothing) = Left imp
-              toEither (imp, Just path) = Right (imp, path)
-              (errs, imports') = partitionEithers (map toEither moduleImports)
-          in case nonEmpty errs of
-            Nothing -> SuccessNode imports'
-            Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs')
-
-        unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors
-        -- The recursion here is fine since we use a lazy map and
-        -- we only recurse on SuccessNodes. In particular, we do not recurse
-        -- on nodes that are part of a cycle as they are already marked as
-        -- error nodes.
-        propagatedErrors =
-          IntMapLazy.map propagate unpropagatedErrors
-        propagate :: NodeResult -> NodeResult
-        propagate n@(ErrorNode _) = n
-        propagate n@(SuccessNode imps) =
-          let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps
-              (errs, _) = partitionNodeResults results
-          in case nonEmpty errs of
-               Nothing -> n
-               Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')
-        findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName)
-        findImport (FilePathId file) importedFile =
-          case g IntMap.! file of
-            Left _ -> error "Tried to call findImport on a module with a parse error"
-            Right ModuleImports{moduleImports} ->
-              fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
-
-graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
-graphEdges g =
-  map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
-  where deps :: Either e ModuleImports -> [FilePathId]
-        deps (Left _) = []
-        deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports
-
-partitionSCC :: [SCC a] -> ([a], [[a]])
-partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
-partitionSCC (AcyclicSCC x:rest) = first (x:)   $ partitionSCC rest
-partitionSCC []                  = ([], [])
-
--- | Transitive reverse dependencies of a file
-transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]
-transitiveReverseDependencies file DependencyInformation{..} = do
-    FilePathId cur_id <- lookupPathToId depPathIdMap file
-    return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))
-  where
-    go :: Int -> IntSet -> IntSet
-    go k i =
-      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps)
-          res = IntSet.union i outwards
-          new = IntSet.difference i outwards
-      in IntSet.foldr go res new
-
--- | Immediate reverse dependencies of a file
-immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]
-immediateReverseDependencies file DependencyInformation{..} = do
-  FilePathId cur_id <- lookupPathToId depPathIdMap file
-  return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))
-
-transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
-transitiveDeps DependencyInformation{..} file = do
-  let !fileId = pathToId depPathIdMap file
-  reachableVs <-
-      -- Delete the starting node
-      IntSet.delete (getFilePathId fileId) .
-      IntSet.fromList . map (fst3 . fromVertex) .
-      reachable g <$> toVertex (getFilePathId fileId)
-  let transitiveModuleDepIds =
-        filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
-  let transitivePkgDeps =
-          Set.toList $ Set.unions $
-          map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
-          getFilePathId fileId : transitiveModuleDepIds
-  let transitiveModuleDeps =
-        map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
-  let transitiveNamedModuleDeps =
-        [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation
-        | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames
-        , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid
-        ]
-  pure TransitiveDependencies {..}
-  where
-    (g, fromVertex, toVertex) = graphFromEdges edges
-    edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
-
-    -- Need to add an edge between the .hs and .hs-boot file if it exists
-    -- so the .hs file gets loaded after the .hs-boot file and the right
-    -- stuff ends up in the HPT. If you don't have this check then GHC will
-    -- fail to work with ghcide.
-    boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
-
-    vs = topSort g
-
-data TransitiveDependencies = TransitiveDependencies
-  { transitiveModuleDeps :: [NormalizedFilePath]
-  -- ^ Transitive module dependencies in topological order.
-  -- The module itself is not included.
-  , transitiveNamedModuleDeps :: [NamedModuleDep]
-  -- ^ Transitive module dependencies in topological order.
-  -- The module itself is not included.
-  , transitivePkgDeps :: [InstalledUnitId]
-  -- ^ Transitive pkg dependencies in unspecified order.
-  } deriving (Eq, Show, Generic)
-
-instance NFData TransitiveDependencies
-
-data NamedModuleDep = NamedModuleDep {
-  nmdFilePath :: !NormalizedFilePath,
-  nmdModuleName :: !ModuleName,
-  nmdModLocation :: !(Maybe ModLocation)
-  }
-  deriving Generic
-
-instance Eq NamedModuleDep where
-  a == b = nmdFilePath a == nmdFilePath b
-
-instance NFData NamedModuleDep where
-  rnf NamedModuleDep{..} =
-    rnf nmdFilePath `seq`
-    rnf nmdModuleName `seq`
-    -- 'ModLocation' lacks an 'NFData' instance
-    rwhnf nmdModLocation
-
-instance Show NamedModuleDep where
-  show NamedModuleDep{..} = show nmdFilePath
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.Import.DependencyInformation+  ( DependencyInformation(..)+  , ModuleImports(..)+  , RawDependencyInformation(..)+  , NodeError(..)+  , ModuleParseError(..)+  , TransitiveDependencies(..)+  , FilePathId(..)+  , NamedModuleDep(..)++  , PathIdMap+  , emptyPathIdMap+  , getPathId+  , lookupPathToId+  , insertImport+  , pathToId+  , idToPath+  , reachableModules+  , processDependencyInformation+  , transitiveDeps+  , transitiveReverseDependencies+  , immediateReverseDependencies++  , BootIdMap+  , insertBootId+  ) where++import Control.DeepSeq+import Data.Bifunctor+import Data.Coerce+import Data.List+import Data.Tuple.Extra hiding (first, second)+import Development.IDE.GHC.Orphans()+import Data.Either+import Data.Graph+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMS+import Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntMap.Lazy as IntMapLazy+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics (Generic)++import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.IDE.Import.FindImports (ArtifactsLocation(..))++import GHC+import Module++-- | The imports for a given module.+data ModuleImports = ModuleImports+    { moduleImports :: ![(Located ModuleName, Maybe FilePathId)]+    -- ^ Imports of a module in the current package and the file path of+    -- that module on disk (if we found it)+    , packageImports :: !(Set InstalledUnitId)+    -- ^ Transitive package dependencies unioned for all imports.+    } deriving Show++-- | For processing dependency information, we need lots of maps and sets of+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet+-- instead and only convert at the edges.+newtype FilePathId = FilePathId { getFilePathId :: Int }+  deriving (Show, NFData, Eq, Ord)++-- | Map from 'FilePathId'+type FilePathIdMap = IntMap++-- | Set of 'FilePathId's+type FilePathIdSet = IntSet++data PathIdMap = PathIdMap+  { idToPathMap :: !(FilePathIdMap ArtifactsLocation)+  , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)+  }+  deriving (Show, Generic)++instance NFData PathIdMap++emptyPathIdMap :: PathIdMap+emptyPathIdMap = PathIdMap IntMap.empty HMS.empty++getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)+getPathId path m@PathIdMap{..} =+    case HMS.lookup (artifactFilePath path) pathToIdMap of+        Nothing ->+            let !newId = FilePathId $ HMS.size pathToIdMap+            in (newId, insertPathId path newId m)+        Just id -> (id, m)++insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap+insertPathId path id PathIdMap{..} =+    PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)++insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation+insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }++pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path++lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap++idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId++idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id++type BootIdMap = FilePathIdMap FilePathId++insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap+insertBootId k = IntMap.insert (getFilePathId k)++-- | Unprocessed results that we find by following imports recursively.+data RawDependencyInformation = RawDependencyInformation+    { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))+    , rawPathIdMap :: !PathIdMap+    -- The rawBootMap maps the FilePathId of a hs-boot file to its+    -- corresponding hs file. It is used when topologically sorting as we+    -- need to add edges between .hs-boot and .hs so that the .hs files+    -- appear later in the sort.+    , rawBootMap :: !BootIdMap+    } deriving Show++pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)+pkgDependencies RawDependencyInformation{..} =+    IntMap.map (either (const Set.empty) packageImports) rawImports++data DependencyInformation =+  DependencyInformation+    { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))+    -- ^ Nodes that cannot be processed correctly.+    , depModuleNames :: !(FilePathIdMap ShowableModuleName)+    , depModuleDeps :: !(FilePathIdMap FilePathIdSet)+    -- ^ For a non-error node, this contains the set of module immediate dependencies+    -- in the same package.+    , depReverseModuleDeps :: !(IntMap IntSet)+    -- ^ Contains a reverse mapping from a module to all those that immediately depend on it.+    , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))+    -- ^ For a non-error node, this contains the set of immediate pkg deps.+    , depPathIdMap :: !PathIdMap+    -- ^ Map from FilePath to FilePathId+    , depBootMap :: !BootIdMap+    -- ^ Map from hs-boot file to the corresponding hs file+    } deriving (Show, Generic)++newtype ShowableModuleName =+  ShowableModuleName {showableModuleName :: ModuleName}+  deriving NFData++instance Show ShowableModuleName where show = moduleNameString . showableModuleName++reachableModules :: DependencyInformation -> [NormalizedFilePath]+reachableModules DependencyInformation{..} =+    map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps++instance NFData DependencyInformation++-- | This does not contain the actual parse error as that is already reported by GetParsedModule.+data ModuleParseError = ModuleParseError+  deriving (Show, Generic)++instance NFData ModuleParseError++-- | Error when trying to locate a module.+data LocateError = LocateError [Diagnostic]+  deriving (Eq, Show, Generic)++instance NFData LocateError++-- | An error attached to a node in the dependency graph.+data NodeError+  = PartOfCycle (Located ModuleName) [FilePathId]+  -- ^ This module is part of an import cycle. The module name corresponds+  -- to the import that enters the cycle starting from this module.+  -- The list of filepaths represents the elements+  -- in the cycle in unspecified order.+  | FailedToLocateImport (Located ModuleName)+  -- ^ This module has an import that couldn’t be located.+  | ParseError ModuleParseError+  | ParentOfErrorNode (Located ModuleName)+  -- ^ This module is the parent of a module that cannot be+  -- processed (either it cannot be parsed, is part of a cycle+  -- or the parent of another error node).+  deriving (Show, Generic)++instance NFData NodeError where+  rnf (PartOfCycle m fs) = m `seq` rnf fs+  rnf (FailedToLocateImport m) = m `seq` ()+  rnf (ParseError e) = rnf e+  rnf (ParentOfErrorNode m) = m `seq` ()++-- | A processed node in the dependency graph. If there was any error+-- during processing the node or any of its dependencies, this is an+-- `ErrorNode`. Otherwise it is a `SuccessNode`.+data NodeResult+  = ErrorNode (NonEmpty NodeError)+  | SuccessNode [(Located ModuleName, FilePathId)]+  deriving Show++partitionNodeResults+    :: [(a, NodeResult)]+    -> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])])+partitionNodeResults = partitionEithers . map f+  where f (a, ErrorNode errs) = Left (a, errs)+        f (a, SuccessNode imps) = Right (a, imps)++instance Semigroup NodeResult where+   ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs')+   ErrorNode errs <> SuccessNode _ = ErrorNode errs+   SuccessNode _ <> ErrorNode errs = ErrorNode errs+   SuccessNode a <> SuccessNode _ = SuccessNode a++processDependencyInformation :: RawDependencyInformation -> DependencyInformation+processDependencyInformation rawDepInfo@RawDependencyInformation{..} =+  DependencyInformation+    { depErrorNodes = IntMap.fromList errorNodes+    , depModuleDeps = moduleDeps+    , depReverseModuleDeps = reverseModuleDeps+    , depModuleNames = IntMap.fromList $ coerce moduleNames+    , depPkgDeps = pkgDependencies rawDepInfo+    , depPathIdMap = rawPathIdMap+    , depBootMap = rawBootMap+    }+  where resultGraph = buildResultGraph rawImports+        (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph+        moduleNames :: [(FilePathId, ModuleName)]+        moduleNames =+          [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]+        successEdges :: [(FilePathId, [FilePathId])]+        successEdges =+            map+              (bimap FilePathId (map snd))+              successNodes+        moduleDeps =+          IntMap.fromList $+          map (\(FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))+            successEdges+        reverseModuleDeps =+          foldr (\(p, cs) res ->+                                  let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))+                                  in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges+++-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:+-- 1. Mark each node that is part of an import cycle as an error node.+-- 2. Mark each node that has a parse error as an error node.+-- 3. Mark each node whose immediate children could not be located as an error.+-- 4. Recursively propagate errors to parents if they are not already error nodes.+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult+buildResultGraph g = propagatedErrors+    where+        sccs = stronglyConnComp (graphEdges g)+        (_, cycles) = partitionSCC sccs+        cycleErrors :: IntMap NodeResult+        cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles+        errorsForCycle :: [FilePathId] -> IntMap NodeResult+        errorsForCycle files =+          IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files+        cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]+        cycleErrorsForFile cycle f =+          let entryPoints = mapMaybe (findImport f) cycle+          in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints+        otherErrors = IntMap.map otherErrorsForFile g+        otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult+        otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])+        otherErrorsForFile (Right ModuleImports{moduleImports}) =+          let toEither (imp, Nothing) = Left imp+              toEither (imp, Just path) = Right (imp, path)+              (errs, imports') = partitionEithers (map toEither moduleImports)+          in case nonEmpty errs of+            Nothing -> SuccessNode imports'+            Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs')++        unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors+        -- The recursion here is fine since we use a lazy map and+        -- we only recurse on SuccessNodes. In particular, we do not recurse+        -- on nodes that are part of a cycle as they are already marked as+        -- error nodes.+        propagatedErrors =+          IntMapLazy.map propagate unpropagatedErrors+        propagate :: NodeResult -> NodeResult+        propagate n@(ErrorNode _) = n+        propagate n@(SuccessNode imps) =+          let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps+              (errs, _) = partitionNodeResults results+          in case nonEmpty errs of+               Nothing -> n+               Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')+        findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName)+        findImport (FilePathId file) importedFile =+          case g IntMap.! file of+            Left _ -> error "Tried to call findImport on a module with a parse error"+            Right ModuleImports{moduleImports} ->+              fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports++graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]+graphEdges g =+  map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g+  where deps :: Either e ModuleImports -> [FilePathId]+        deps (Left _) = []+        deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports++partitionSCC :: [SCC a] -> ([a], [[a]])+partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest+partitionSCC (AcyclicSCC x:rest) = first (x:)   $ partitionSCC rest+partitionSCC []                  = ([], [])++-- | Transitive reverse dependencies of a file+transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]+transitiveReverseDependencies file DependencyInformation{..} = do+    FilePathId cur_id <- lookupPathToId depPathIdMap file+    return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty))+  where+    go :: Int -> IntSet -> IntSet+    go k i =+      let outwards = fromMaybe IntSet.empty (IntMap.lookup k depReverseModuleDeps)+          res = IntSet.union i outwards+          new = IntSet.difference i outwards+      in IntSet.foldr go res new++-- | Immediate reverse dependencies of a file+immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath]+immediateReverseDependencies file DependencyInformation{..} = do+  FilePathId cur_id <- lookupPathToId depPathIdMap file+  return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))++transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies+transitiveDeps DependencyInformation{..} file = do+  let !fileId = pathToId depPathIdMap file+  reachableVs <-+      -- Delete the starting node+      IntSet.delete (getFilePathId fileId) .+      IntSet.fromList . map (fst3 . fromVertex) .+      reachable g <$> toVertex (getFilePathId fileId)+  let transitiveModuleDepIds =+        filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs+  let transitivePkgDeps =+          Set.toList $ Set.unions $+          map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $+          getFilePathId fileId : transitiveModuleDepIds+  let transitiveModuleDeps =+        map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds+  let transitiveNamedModuleDeps =+        [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation+        | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames+        , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid+        ]+  pure TransitiveDependencies {..}+  where+    (g, fromVertex, toVertex) = graphFromEdges edges+    edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps++    -- Need to add an edge between the .hs and .hs-boot file if it exists+    -- so the .hs file gets loaded after the .hs-boot file and the right+    -- stuff ends up in the HPT. If you don't have this check then GHC will+    -- fail to work with ghcide.+    boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]++    vs = topSort g++data TransitiveDependencies = TransitiveDependencies+  { transitiveModuleDeps :: [NormalizedFilePath]+  -- ^ Transitive module dependencies in topological order.+  -- The module itself is not included.+  , transitiveNamedModuleDeps :: [NamedModuleDep]+  -- ^ Transitive module dependencies in topological order.+  -- The module itself is not included.+  , transitivePkgDeps :: [InstalledUnitId]+  -- ^ Transitive pkg dependencies in unspecified order.+  } deriving (Eq, Show, Generic)++instance NFData TransitiveDependencies++data NamedModuleDep = NamedModuleDep {+  nmdFilePath :: !NormalizedFilePath,+  nmdModuleName :: !ModuleName,+  nmdModLocation :: !(Maybe ModLocation)+  }+  deriving Generic++instance Eq NamedModuleDep where+  a == b = nmdFilePath a == nmdFilePath b++instance NFData NamedModuleDep where+  rnf NamedModuleDep{..} =+    rnf nmdFilePath `seq`+    rnf nmdModuleName `seq`+    -- 'ModLocation' lacks an 'NFData' instance+    rwhnf nmdModLocation++instance Show NamedModuleDep where+  show NamedModuleDep{..} = show nmdFilePath
src/Development/IDE/Import/FindImports.hs view
@@ -1,178 +1,178 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP #-}
-#include "ghc-api-version.h"
-
-module Development.IDE.Import.FindImports
-  ( locateModule
-  , Import(..)
-  , ArtifactsLocation(..)
-  , modSummaryToArtifactsLocation
-  , isBootLocation
-  , mkImportDirs
-  ) where
-
-import           Development.IDE.GHC.Error as ErrUtils
-import Development.IDE.GHC.Orphans()
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Location
-import Development.IDE.GHC.Compat
--- GHC imports
-import           FastString
-import qualified Module                      as M
-import           Packages
-import           Outputable                  (showSDoc, ppr, pprPanic)
-import           Finder
-import Control.DeepSeq
-
--- standard imports
-import           Control.Monad.Extra
-import           Control.Monad.IO.Class
-import           System.FilePath
-import DriverPhases
-import Data.Maybe
-import Data.List (isSuffixOf)
-
-data Import
-  = FileImport !ArtifactsLocation
-  | PackageImport !M.InstalledUnitId
-  deriving (Show)
-
-data ArtifactsLocation = ArtifactsLocation
-  { artifactFilePath    :: !NormalizedFilePath
-  , artifactModLocation :: !(Maybe ModLocation)
-  , artifactIsSource    :: !Bool          -- ^ True if a module is a source input
-  }
-    deriving (Show)
-
-instance NFData ArtifactsLocation where
-  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
-
-isBootLocation :: ArtifactsLocation -> Bool
-isBootLocation = not . artifactIsSource
-
-instance NFData Import where
-  rnf (FileImport x) = rnf x
-  rnf (PackageImport x) = rnf x
-
-modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation
-modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source
-  where
-    isSource HsSrcFile = True
-    isSource _ = False
-    source = case ms of
-      Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp
-      Just ms -> isSource (ms_hsc_src ms)
-
--- | locate a module in the file system. Where we go from *daml to Haskell
-locateModuleFile :: MonadIO m
-             => [[FilePath]]
-             -> [String]
-             -> (ModuleName -> NormalizedFilePath -> m Bool)
-             -> Bool
-             -> ModuleName
-             -> m (Maybe NormalizedFilePath)
-locateModuleFile import_dirss exts doesExist 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)
-  where
-    maybeBoot ext
-      | isSource = ext ++ "-boot"
-      | otherwise = ext
-
--- | This function is used to map a package name to a set of import paths.
--- It only returns Just for unit-ids which are possible to import into the
--- current module. In particular, it will return Nothing for 'main' components
--- as they can never be imported into another package.
-mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])
-mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i
-
--- | locate a module in either the file system or the package database. Where we go from *daml to
--- Haskell
-locateModule
-    :: MonadIO m
-    => DynFlags
-    -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories
-    -> [String]                        -- ^ File extensions
-    -> (ModuleName -> NormalizedFilePath -> m Bool)  -- ^ does file exist predicate
-    -> Located ModuleName              -- ^ Moudle name
-    -> Maybe FastString                -- ^ Package name
-    -> Bool                            -- ^ Is boot module
-    -> m (Either [FileDiagnostic] Import)
-locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
-  case mbPkgName of
-    -- "this" means that we should only look in the current package
-    Just "this" -> do
-      lookupLocal [importPaths dflags]
-    -- if a package name is given we only go look for a package
-    Just pkgName
-      | Just dirs <- lookup (PackageName pkgName) import_paths
-          -> lookupLocal [dirs]
-      | otherwise -> lookupInPackageDB dflags
-    Nothing -> do
-      -- first try to find the module as a file. If we can't find it try to find it in the package
-      -- database.
-      -- 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
-      case mbFile of
-        Nothing -> lookupInPackageDB dflags
-        Just file -> toModLocation file
-  where
-    import_paths = mapMaybe (mkImportDirs dflags) comp_info
-    toModLocation file = liftIO $ do
-        loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
-        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)
-
-    lookupLocal dirs = do
-      mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName
-      case mbFile of
-        Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
-        Just file -> toModLocation file
-
-    lookupInPackageDB dfs =
-      case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
-        LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
-        reason -> return $ Left $ notFoundErr dfs modName reason
-
--- | Don't call this on a found module.
-notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic]
-notFoundErr dfs modName reason =
-  mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason
-  where
-    mkError' = diagFromString "not found" DsError (getLoc modName)
-    modName0 = unLoc modName
-    ppr' = showSDoc dfs
-    -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.
-    lookupToFindResult =
-      \case
-        LookupFound _m _pkgConfig ->
-          pprPanic "Impossible: called lookupToFind on found module." (ppr modName0)
-        LookupMultiple rs -> FoundMultiple rs
-        LookupHidden pkg_hiddens mod_hiddens ->
-          notFound
-             { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens
-             , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens
-             }
-        LookupUnusable unusable ->
-          let unusables' = map get_unusable unusable
-              get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
-              get_unusable (_, r) =
-                pprPanic "findLookupResult: unexpected origin" (ppr r)
-           in notFound {fr_unusables = unusables'}
-        LookupNotFound suggest ->
-          notFound {fr_suggestions = suggest}
-
-notFound :: FindResult
-notFound = NotFound
-  { fr_paths = []
-  , fr_pkg = Nothing
-  , fr_pkgs_hidden = []
-  , fr_mods_hidden = []
-  , fr_unusables = []
-  , fr_suggestions = []
-  }
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"++module Development.IDE.Import.FindImports+  ( locateModule+  , Import(..)+  , ArtifactsLocation(..)+  , modSummaryToArtifactsLocation+  , isBootLocation+  , mkImportDirs+  ) where++import           Development.IDE.GHC.Error as ErrUtils+import Development.IDE.GHC.Orphans()+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.IDE.GHC.Compat+-- GHC imports+import           FastString+import qualified Module                      as M+import           Packages+import           Outputable                  (showSDoc, ppr, pprPanic)+import           Finder+import Control.DeepSeq++-- standard imports+import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           System.FilePath+import DriverPhases+import Data.Maybe+import Data.List (isSuffixOf)++data Import+  = FileImport !ArtifactsLocation+  | PackageImport !M.InstalledUnitId+  deriving (Show)++data ArtifactsLocation = ArtifactsLocation+  { artifactFilePath    :: !NormalizedFilePath+  , artifactModLocation :: !(Maybe ModLocation)+  , artifactIsSource    :: !Bool          -- ^ True if a module is a source input+  }+    deriving (Show)++instance NFData ArtifactsLocation where+  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource++isBootLocation :: ArtifactsLocation -> Bool+isBootLocation = not . artifactIsSource++instance NFData Import where+  rnf (FileImport x) = rnf x+  rnf (PackageImport x) = rnf x++modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source+  where+    isSource HsSrcFile = True+    isSource _ = False+    source = case ms of+      Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp+      Just ms -> isSource (ms_hsc_src ms)++-- | locate a module in the file system. Where we go from *daml to Haskell+locateModuleFile :: MonadIO m+             => [[FilePath]]+             -> [String]+             -> (ModuleName -> NormalizedFilePath -> m Bool)+             -> Bool+             -> ModuleName+             -> m (Maybe NormalizedFilePath)+locateModuleFile import_dirss exts doesExist 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)+  where+    maybeBoot ext+      | isSource = ext ++ "-boot"+      | otherwise = ext++-- | This function is used to map a package name to a set of import paths.+-- It only returns Just for unit-ids which are possible to import into the+-- current module. In particular, it will return Nothing for 'main' components+-- as they can never be imported into another package.+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i++-- | locate a module in either the file system or the package database. Where we go from *daml to+-- Haskell+locateModule+    :: MonadIO m+    => DynFlags+    -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories+    -> [String]                        -- ^ File extensions+    -> (ModuleName -> NormalizedFilePath -> m Bool)  -- ^ does file exist predicate+    -> Located ModuleName              -- ^ Moudle name+    -> Maybe FastString                -- ^ Package name+    -> Bool                            -- ^ Is boot module+    -> m (Either [FileDiagnostic] Import)+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do+  case mbPkgName of+    -- "this" means that we should only look in the current package+    Just "this" -> do+      lookupLocal [importPaths dflags]+    -- if a package name is given we only go look for a package+    Just pkgName+      | Just dirs <- lookup (PackageName pkgName) import_paths+          -> lookupLocal [dirs]+      | otherwise -> lookupInPackageDB dflags+    Nothing -> do+      -- first try to find the module as a file. If we can't find it try to find it in the package+      -- database.+      -- 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+      case mbFile of+        Nothing -> lookupInPackageDB dflags+        Just file -> toModLocation file+  where+    import_paths = mapMaybe (mkImportDirs dflags) comp_info+    toModLocation file = liftIO $ do+        loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)+        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)++    lookupLocal dirs = do+      mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName+      case mbFile of+        Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []+        Just file -> toModLocation file++    lookupInPackageDB dfs =+      case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of+        LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig+        reason -> return $ Left $ notFoundErr dfs modName reason++-- | Don't call this on a found module.+notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic]+notFoundErr dfs modName reason =+  mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason+  where+    mkError' = diagFromString "not found" DsError (getLoc modName)+    modName0 = unLoc modName+    ppr' = showSDoc dfs+    -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.+    lookupToFindResult =+      \case+        LookupFound _m _pkgConfig ->+          pprPanic "Impossible: called lookupToFind on found module." (ppr modName0)+        LookupMultiple rs -> FoundMultiple rs+        LookupHidden pkg_hiddens mod_hiddens ->+          notFound+             { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens+             , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens+             }+        LookupUnusable unusable ->+          let unusables' = map get_unusable unusable+              get_unusable (m, ModUnusable r) = (moduleUnitId m, r)+              get_unusable (_, r) =+                pprPanic "findLookupResult: unexpected origin" (ppr r)+           in notFound {fr_unusables = unusables'}+        LookupNotFound suggest ->+          notFound {fr_suggestions = suggest}++notFound :: FindResult+notFound = NotFound+  { fr_paths = []+  , fr_pkg = Nothing+  , fr_pkgs_hidden = []+  , fr_mods_hidden = []+  , fr_unusables = []+  , fr_suggestions = []+  }
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -1,72 +1,72 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-
--- | Display information on hover.
-module Development.IDE.LSP.HoverDefinition
-    ( setHandlersHover
-    , setHandlersDefinition
-    , setHandlersTypeDefinition
-    , setHandlersDocHighlight
-    -- * For haskell-language-server
-    , hover
-    , gotoDefinition
-    , gotoTypeDefinition
-    ) where
-
-import           Development.IDE.Core.Rules
-import           Development.IDE.Core.Shake
-import           Development.IDE.LSP.Server
-import           Development.IDE.Types.Location
-import           Development.IDE.Types.Logger
-import qualified Language.Haskell.LSP.Core       as LSP
-import           Language.Haskell.LSP.Messages
-import           Language.Haskell.LSP.Types
-
-import qualified Data.Text as T
-
-gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
-hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
-documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))
-gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc
-hover          = request "Hover"      getAtPoint     Nothing      foundHover
-documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
-
-foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
-foundHover (mbRange, contents) =
-  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
-
-setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
-setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
-setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
-setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.hoverHandler      = withResponse RspHover      $ const hover}
-setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}
-
--- | Respond to and log a hover or go-to-definition request
-request
-  :: T.Text
-  -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
-  -> b
-  -> (a -> b)
-  -> IdeState
-  -> TextDocumentPositionParams
-  -> IO (Either ResponseError b)
-request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
-    mbResult <- case uriToFilePath' uri of
-        Just path -> logAndRunRequest label getResults ide pos path
-        Nothing   -> pure Nothing
-    pure $ Right $ maybe notFound found mbResult
-
-logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
-logAndRunRequest label getResults ide pos path = do
-  let filePath = toNormalizedFilePath' path
-  logInfo (ideLogger ide) $
-    label <> " request at position " <> T.pack (showPosition pos) <>
-    " in file: " <> T.pack path
-  runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+++-- | Display information on hover.+module Development.IDE.LSP.HoverDefinition+    ( setHandlersHover+    , setHandlersDefinition+    , setHandlersTypeDefinition+    , setHandlersDocHighlight+    -- * For haskell-language-server+    , hover+    , gotoDefinition+    , gotoTypeDefinition+    ) where++import           Development.IDE.Core.Rules+import           Development.IDE.Core.Shake+import           Development.IDE.LSP.Server+import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger+import qualified Language.Haskell.LSP.Core       as LSP+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types++import qualified Data.Text as T++gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)+hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))+gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)+documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))+gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc+hover          = request "Hover"      getAtPoint     Nothing      foundHover+documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List++foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover+foundHover (mbRange, contents) =+  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange++setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}+setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}+setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.hoverHandler      = withResponse RspHover      $ const hover}+setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}++-- | Respond to and log a hover or go-to-definition request+request+  :: T.Text+  -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))+  -> b+  -> (a -> b)+  -> IdeState+  -> TextDocumentPositionParams+  -> IO (Either ResponseError b)+request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do+    mbResult <- case uriToFilePath' uri of+        Just path -> logAndRunRequest label getResults ide pos path+        Nothing   -> pure Nothing+    pure $ Right $ maybe notFound found mbResult++logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b+logAndRunRequest label getResults ide pos path = do+  let filePath = toNormalizedFilePath' path+  logInfo (ideLogger ide) $+    label <> " request at position " <> T.pack (showPosition pos) <>+    " in file: " <> T.pack path+  runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)
src/Development/IDE/LSP/LanguageServer.hs view
@@ -1,256 +1,256 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE ExistentialQuantification  #-}
-{-# LANGUAGE RankNTypes                 #-}
-
--- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
--- This version removes the daml: handling
-module Development.IDE.LSP.LanguageServer
-    ( runLanguageServer
-    ) where
-
-import           Language.Haskell.LSP.Types
-import           Language.Haskell.LSP.Types.Capabilities
-import           Development.IDE.LSP.Server
-import qualified Development.IDE.GHC.Util as Ghcide
-import qualified Language.Haskell.LSP.Control as LSP
-import qualified Language.Haskell.LSP.Core as LSP
-import Control.Concurrent.Chan
-import Control.Concurrent.Extra
-import Control.Concurrent.Async
-import Control.Concurrent.STM
-import Control.Exception.Safe
-import Data.Default
-import Data.Maybe
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import GHC.IO.Handle (hDuplicate)
-import System.IO
-import Control.Monad.Extra
-
-import Development.IDE.Core.IdeConfiguration
-import Development.IDE.Core.Shake
-import Development.IDE.LSP.HoverDefinition
-import Development.IDE.LSP.Notifications
-import Development.IDE.LSP.Outline
-import Development.IDE.Types.Logger
-import Development.IDE.Core.FileStore
-import Development.IDE.Core.Tracing
-import Language.Haskell.LSP.Core (LspFuncs(..))
-import Language.Haskell.LSP.Messages
-
-runLanguageServer
-    :: forall config. (Show config)
-    => LSP.Options
-    -> PartialHandlers config
-    -> (InitializeRequest -> Either T.Text config)
-    -> (DidChangeConfigurationNotification -> Either T.Text config)
-    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities
-        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState)
-    -> IO ()
-runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
-    -- Move stdout to another file descriptor and duplicate stderr
-    -- to stdout. This guards against stray prints from corrupting the JSON-RPC
-    -- message stream.
-    newStdout <- hDuplicate stdout
-    stderr `Ghcide.hDuplicateTo'` stdout
-    hSetBuffering stderr NoBuffering
-    hSetBuffering stdout NoBuffering
-
-    -- Print out a single space to assert that the above redirection works.
-    -- This is interleaved with the logger, hence we just print a space here in
-    -- order not to mess up the output too much. Verified that this breaks
-    -- the language server tests without the redirection.
-    putStr " " >> hFlush stdout
-
-    -- Send everything over a channel, since you need to wait until after initialise before
-    -- LspFuncs is available
-    clientMsgChan :: Chan (Message config) <- newChan
-
-    -- These barriers are signaled when the threads reading from these chans exit.
-    -- This should not happen but if it does, we will make sure that the whole server
-    -- dies and can be restarted instead of losing threads silently.
-    clientMsgBarrier <- newBarrier
-    -- Forcefully exit
-    let exit = signalBarrier clientMsgBarrier ()
-
-    -- The set of requests ids that we have received but not finished processing
-    pendingRequests <- newTVarIO Set.empty
-    -- The set of requests that have been cancelled and are also in pendingRequests
-    cancelledRequests <- newTVarIO Set.empty
-
-    let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do
-            atomically $ modifyTVar pendingRequests (Set.insert _id)
-            writeChan clientMsgChan $ Response r wrap f
-    let withNotification old f = Just $ \r@NotificationMessage{_method} ->
-            writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))
-    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do
-            atomically $ modifyTVar pendingRequests (Set.insert _id)
-            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
-    let withInitialize f = Just $ \r ->
-            writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
-    let cancelRequest reqId = atomically $ do
-            queued <- readTVar pendingRequests
-            -- We want to avoid that the list of cancelled requests
-            -- keeps growing if we receive cancellations for requests
-            -- that do not exist or have already been processed.
-            when (reqId `elem` queued) $
-                modifyTVar cancelledRequests (Set.insert reqId)
-    let clearReqId reqId = atomically $ do
-            modifyTVar pendingRequests (Set.delete reqId)
-            modifyTVar cancelledRequests (Set.delete reqId)
-        -- We implement request cancellation by racing waitForCancel against
-        -- the actual request handler.
-    let waitForCancel reqId = atomically $ do
-            cancelled <- readTVar cancelledRequests
-            unless (reqId `Set.member` cancelled) retry
-    let PartialHandlers parts =
-            initializeRequestHandler <>
-            setHandlersIgnore <> -- least important
-            setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>
-            setHandlersDocHighlight <>
-            setHandlersOutline <>
-            userHandlers <>
-            setHandlersNotifications <> -- absolutely critical, join them with user notifications
-            cancelHandler cancelRequest <>
-            exitHandler exit
-            -- Cancel requests are special since they need to be handled
-            -- out of order to be useful. Existing handlers are run afterwards.
-    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
-
-    let initializeCallbacks = LSP.InitializeCallbacks
-            { LSP.onInitialConfiguration = onInitialConfig
-            , LSP.onConfigurationChange = onConfigChange
-            , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan
-            }
-
-    void $ waitAnyCancel =<< traverse async
-        [ void $ LSP.runWithHandles
-            stdin
-            newStdout
-            initializeCallbacks
-            handlers
-            (modifyOptions options)
-            Nothing
-        , void $ waitBarrier clientMsgBarrier
-        ]
-    where
-        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
-        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
-
-            ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
-                               withProgress withIndefiniteProgress config rootPath
-
-            _ <- flip forkFinally (const exitClientMsg) $ forever $ do
-                msg <- readChan clientMsgChan
-                -- We dispatch notifications synchronously and requests asynchronously
-                -- This is to ensure that all file edits and config changes are applied before a request is handled
-                case msg of
-                    Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do
-                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
-                            logError (ideLogger ide) $ T.pack $
-                                "Unexpected exception on notification, please report!\n" ++
-                                "Message: " ++ show x ++ "\n" ++
-                                "Exception: " ++ show e
-                    Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $
-                        otTracedHandler "Request" (show _method) $
-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
-                            \case
-                              Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
-                              Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
-                    ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $
-                        otTracedHandler "Request" (show _method) $
-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
-                            \(res, newReq) -> do
-                                case res of
-                                    Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
-                                    Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
-                                whenJust newReq $ \(rm, newReqParams) -> do
-                                    reqId <- getNextReqId
-                                    sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
-                    InitialParams x@RequestMessage{_id, _method, _params} act ->
-                        otTracedHandler "Initialize" (show _method) $
-                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
-                            logError (ideLogger ide) $ T.pack $
-                                "Unexpected exception on InitializeRequest handler, please report!\n" ++
-                                "Message: " ++ show x ++ "\n" ++
-                                "Exception: " ++ show e
-            pure Nothing
-
-        checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
-            flip finally (clearReqId _id) $
-                catch (do
-                    -- We could optimize this by first checking if the id
-                    -- is in the cancelled set. However, this is unlikely to be a
-                    -- bottleneck and the additional check might hide
-                    -- issues with async exceptions that need to be fixed.
-                    cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params
-                    case cancelOrRes of
-                        Left () -> do
-                            logDebug (ideLogger ide) $ T.pack $
-                                "Cancelled request " <> show _id
-                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
-                                $ ResponseError RequestCancelled "" Nothing
-                        Right res -> k res
-                ) $ \(e :: SomeException) -> do
-                    logError (ideLogger ide) $ T.pack $
-                        "Unexpected exception on request, please report!\n" ++
-                        "Message: " ++ show msg ++ "\n" ++
-                        "Exception: " ++ show e
-                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
-                        $ ResponseError InternalError (T.pack $ show e) Nothing
-
-initializeRequestHandler :: PartialHandlers config
-initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.initializeRequestHandler = withInitialize initHandler
-    }
-
-initHandler
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> InitializeParams
-    -> IO ()
-initHandler _ ide params = do
-    let initConfig = parseConfiguration params
-    logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
-    registerIdeConfiguration (shakeExtras ide) initConfig
-
--- | Things that get sent to us, but we don't deal with.
---   Set them to avoid a warning in VS Code output.
-setHandlersIgnore :: PartialHandlers config
-setHandlersIgnore = PartialHandlers $ \_ x -> return x
-    {LSP.responseHandler = none
-    }
-    where none = Just $ const $ return ()
-
-cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
-cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
-    {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
-            cancelRequest _id
-            whenJust (LSP.cancelNotificationHandler x) ($ msg)
-    }
-
-exitHandler :: IO () -> PartialHandlers c
-exitHandler exit = PartialHandlers $ \_ x -> return x
-    {LSP.exitNotificationHandler = Just $ const exit}
-
--- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
---   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
-data Message c
-    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
-    -- | Used for cases in which we need to send not only a response,
-    --   but also an additional request to the client.
-    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
-    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
-    -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
-    | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
-
-modifyOptions :: LSP.Options -> LSP.Options
-modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS
-                   }
-    where
-        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
-        origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x
-        tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE RankNTypes                 #-}++-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync+-- This version removes the daml: handling+module Development.IDE.LSP.LanguageServer+    ( runLanguageServer+    ) where++import           Language.Haskell.LSP.Types+import           Language.Haskell.LSP.Types.Capabilities+import           Development.IDE.LSP.Server+import qualified Development.IDE.GHC.Util as Ghcide+import qualified Language.Haskell.LSP.Control as LSP+import qualified Language.Haskell.LSP.Core as LSP+import Control.Concurrent.Chan+import Control.Concurrent.Extra+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception.Safe+import Data.Default+import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Text as T+import GHC.IO.Handle (hDuplicate)+import System.IO+import Control.Monad.Extra++import Development.IDE.Core.IdeConfiguration+import Development.IDE.Core.Shake+import Development.IDE.LSP.HoverDefinition+import Development.IDE.LSP.Notifications+import Development.IDE.LSP.Outline+import Development.IDE.Types.Logger+import Development.IDE.Core.FileStore+import Development.IDE.Core.Tracing+import Language.Haskell.LSP.Core (LspFuncs(..))+import Language.Haskell.LSP.Messages++runLanguageServer+    :: forall config. (Show config)+    => LSP.Options+    -> PartialHandlers config+    -> (InitializeRequest -> Either T.Text config)+    -> (DidChangeConfigurationNotification -> Either T.Text config)+    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities+        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState)+    -> IO ()+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do+    -- Move stdout to another file descriptor and duplicate stderr+    -- to stdout. This guards against stray prints from corrupting the JSON-RPC+    -- message stream.+    newStdout <- hDuplicate stdout+    stderr `Ghcide.hDuplicateTo'` stdout+    hSetBuffering stderr NoBuffering+    hSetBuffering stdout NoBuffering++    -- Print out a single space to assert that the above redirection works.+    -- This is interleaved with the logger, hence we just print a space here in+    -- order not to mess up the output too much. Verified that this breaks+    -- the language server tests without the redirection.+    putStr " " >> hFlush stdout++    -- Send everything over a channel, since you need to wait until after initialise before+    -- LspFuncs is available+    clientMsgChan :: Chan (Message config) <- newChan++    -- These barriers are signaled when the threads reading from these chans exit.+    -- This should not happen but if it does, we will make sure that the whole server+    -- dies and can be restarted instead of losing threads silently.+    clientMsgBarrier <- newBarrier+    -- Forcefully exit+    let exit = signalBarrier clientMsgBarrier ()++    -- The set of requests ids that we have received but not finished processing+    pendingRequests <- newTVarIO Set.empty+    -- The set of requests that have been cancelled and are also in pendingRequests+    cancelledRequests <- newTVarIO Set.empty++    let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do+            atomically $ modifyTVar pendingRequests (Set.insert _id)+            writeChan clientMsgChan $ Response r wrap f+    let withNotification old f = Just $ \r@NotificationMessage{_method} ->+            writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))+    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do+            atomically $ modifyTVar pendingRequests (Set.insert _id)+            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f+    let withInitialize f = Just $ \r ->+            writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)+    let cancelRequest reqId = atomically $ do+            queued <- readTVar pendingRequests+            -- We want to avoid that the list of cancelled requests+            -- keeps growing if we receive cancellations for requests+            -- that do not exist or have already been processed.+            when (reqId `elem` queued) $+                modifyTVar cancelledRequests (Set.insert reqId)+    let clearReqId reqId = atomically $ do+            modifyTVar pendingRequests (Set.delete reqId)+            modifyTVar cancelledRequests (Set.delete reqId)+        -- We implement request cancellation by racing waitForCancel against+        -- the actual request handler.+    let waitForCancel reqId = atomically $ do+            cancelled <- readTVar cancelledRequests+            unless (reqId `Set.member` cancelled) retry+    let PartialHandlers parts =+            initializeRequestHandler <>+            setHandlersIgnore <> -- least important+            setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>+            setHandlersDocHighlight <>+            setHandlersOutline <>+            userHandlers <>+            setHandlersNotifications <> -- absolutely critical, join them with user notifications+            cancelHandler cancelRequest <>+            exitHandler exit+            -- Cancel requests are special since they need to be handled+            -- out of order to be useful. Existing handlers are run afterwards.+    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def++    let initializeCallbacks = LSP.InitializeCallbacks+            { LSP.onInitialConfiguration = onInitialConfig+            , LSP.onConfigurationChange = onConfigChange+            , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan+            }++    void $ waitAnyCancel =<< traverse async+        [ void $ LSP.runWithHandles+            stdin+            newStdout+            initializeCallbacks+            handlers+            (modifyOptions options)+            Nothing+        , void $ waitBarrier clientMsgBarrier+        ]+    where+        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)+        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do++            ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities+                               withProgress withIndefiniteProgress config rootPath++            _ <- flip forkFinally (const exitClientMsg) $ forever $ do+                msg <- readChan clientMsgChan+                -- We dispatch notifications synchronously and requests asynchronously+                -- This is to ensure that all file edits and config changes are applied before a request is handled+                case msg of+                    Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do+                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->+                            logError (ideLogger ide) $ T.pack $+                                "Unexpected exception on notification, please report!\n" +++                                "Message: " ++ show x ++ "\n" +++                                "Exception: " ++ show e+                    Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $+                        otTracedHandler "Request" (show _method) $+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $+                            \case+                              Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)+                              Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)+                    ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $+                        otTracedHandler "Request" (show _method) $+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $+                            \(res, newReq) -> do+                                case res of+                                    Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)+                                    Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)+                                whenJust newReq $ \(rm, newReqParams) -> do+                                    reqId <- getNextReqId+                                    sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams+                    InitialParams x@RequestMessage{_id, _method, _params} act ->+                        otTracedHandler "Initialize" (show _method) $+                        catch (act lspFuncs ide _params) $ \(e :: SomeException) ->+                            logError (ideLogger ide) $ T.pack $+                                "Unexpected exception on InitializeRequest handler, please report!\n" +++                                "Message: " ++ show x ++ "\n" +++                                "Exception: " ++ show e+            pure Nothing++        checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =+            flip finally (clearReqId _id) $+                catch (do+                    -- We could optimize this by first checking if the id+                    -- is in the cancelled set. However, this is unlikely to be a+                    -- bottleneck and the additional check might hide+                    -- issues with async exceptions that need to be fixed.+                    cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params+                    case cancelOrRes of+                        Left () -> do+                            logDebug (ideLogger ide) $ T.pack $+                                "Cancelled request " <> show _id+                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left+                                $ ResponseError RequestCancelled "" Nothing+                        Right res -> k res+                ) $ \(e :: SomeException) -> do+                    logError (ideLogger ide) $ T.pack $+                        "Unexpected exception on request, please report!\n" +++                        "Message: " ++ show msg ++ "\n" +++                        "Exception: " ++ show e+                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left+                        $ ResponseError InternalError (T.pack $ show e) Nothing++initializeRequestHandler :: PartialHandlers config+initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.initializeRequestHandler = withInitialize initHandler+    }++initHandler+    :: LSP.LspFuncs c+    -> IdeState+    -> InitializeParams+    -> IO ()+initHandler _ ide params = do+    let initConfig = parseConfiguration params+    logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig+    registerIdeConfiguration (shakeExtras ide) initConfig++-- | Things that get sent to us, but we don't deal with.+--   Set them to avoid a warning in VS Code output.+setHandlersIgnore :: PartialHandlers config+setHandlersIgnore = PartialHandlers $ \_ x -> return x+    {LSP.responseHandler = none+    }+    where none = Just $ const $ return ()++cancelHandler :: (LspId -> IO ()) -> PartialHandlers config+cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x+    {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do+            cancelRequest _id+            whenJust (LSP.cancelNotificationHandler x) ($ msg)+    }++exitHandler :: IO () -> PartialHandlers c+exitHandler exit = PartialHandlers $ \_ x -> return x+    {LSP.exitNotificationHandler = Just $ const exit}++-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety+--   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)+data Message c+    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))+    -- | Used for cases in which we need to send not only a response,+    --   but also an additional request to the client.+    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.+    | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))+    | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())+    -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.+    | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())++modifyOptions :: LSP.Options -> LSP.Options+modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS+                   }+    where+        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}+        origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x+        tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing
src/Development/IDE/LSP/Notifications.hs view
@@ -1,148 +1,148 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE RankNTypes            #-}
-
-module Development.IDE.LSP.Notifications
-    ( setHandlersNotifications
-    ) where
-
-import           Development.IDE.LSP.Server
-import qualified Language.Haskell.LSP.Core        as LSP
-import           Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Types       as LSP
-import qualified Language.Haskell.LSP.Messages    as LSP
-import qualified Language.Haskell.LSP.Types.Capabilities as LSP
-
-import           Development.IDE.Core.IdeConfiguration
-import           Development.IDE.Core.Service
-import           Development.IDE.Core.Shake
-import           Development.IDE.Types.Location
-import           Development.IDE.Types.Logger
-import           Development.IDE.Types.Options
-
-import           Control.Monad.Extra
-import qualified Data.Aeson                       as A
-import           Data.Foldable                    as F
-import           Data.Maybe
-import qualified Data.HashMap.Strict              as M
-import qualified Data.HashSet                     as S
-import qualified Data.Text                        as Text
-
-import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified, typecheckParents)
-import           Development.IDE.Core.FileExists  (modifyFileExists, watchedGlobs)
-import           Development.IDE.Core.OfInterest
-import Ide.Plugin.Config (CheckParents(CheckOnClose))
-
-
-whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
-whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
-
-setHandlersNotifications :: PartialHandlers c
-setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
-    {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
-        \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
-            updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])
-            whenUriFile _uri $ \file -> do
-                -- We don't know if the file actually exists, or if the contents match those on disk
-                -- For example, vscode restores previously unsaved contents on open
-                modifyFilesOfInterest ide (M.insert file Modified)
-                setFileModified ide False file
-                logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri
-
-    ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $
-        \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do
-            updatePositionMapping ide identifier changes
-            whenUriFile _uri $ \file -> do
-              modifyFilesOfInterest ide (M.insert file Modified)
-              setFileModified ide False file
-            logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri
-
-    ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $
-        \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do
-            whenUriFile _uri $ \file -> do
-                modifyFilesOfInterest ide (M.insert file OnDisk)
-                setFileModified ide True file
-            logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri
-
-    ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $
-        \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do
-            whenUriFile _uri $ \file -> do
-                modifyFilesOfInterest ide (M.delete file)
-                -- Refresh all the files that depended on this
-                IdeOptions{optCheckParents} <- getIdeOptionsIO $ shakeExtras ide
-                when (optCheckParents >= CheckOnClose) $ typecheckParents ide file
-                logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
-    ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $
-        \_ ide (DidChangeWatchedFilesParams fileEvents) -> do
-            -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and
-            -- what we do with them
-            let events =
-                    mapMaybe
-                        (\(FileEvent uri ev) ->
-                            (, ev /= FcDeleted) . toNormalizedFilePath'
-                            <$> LSP.uriToFilePath uri
-                        )
-                        ( F.toList fileEvents )
-            let msg = Text.pack $ show events
-            logDebug (ideLogger ide) $ "Files created or deleted: " <> msg
-            modifyFileExists ide events
-            setSomethingModified ide
-
-    ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $
-        \_ ide (DidChangeWorkspaceFoldersParams events) -> do
-            let add       = S.union
-                substract = flip S.difference
-            modifyWorkspaceFolders ide
-              $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))
-              . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
-
-    ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $
-        \_ ide (DidChangeConfigurationParams cfg) -> do
-            let msg = Text.pack $ show cfg
-            logInfo (ideLogger ide) $ "Configuration changed: " <> msg
-            modifyClientSettings ide (const $ Just cfg)
-            setSomethingModified ide
-
-    -- Initialized handler, good time to dynamically register capabilities
-    ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do
-        let watchSupported = case () of
-              _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
-                , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
-                , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
-                , Just True <- _dynamicRegistration
-                  -> True
-                | otherwise -> False
-
-        if watchSupported
-        then registerWatcher lsp ide
-        else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
-
-    }
-    where
-        registerWatcher LSP.LspFuncs{..} ide = do
-            lspId <- getNextReqId
-            opts <- getIdeOptionsIO $ shakeExtras ide
-            let
-              req = RequestMessage "2.0" lspId ClientRegisterCapability regParams
-              regParams    = RegistrationParams (List [registration])
-              -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
-              -- We could also use something like a random UUID, as some other servers do, but this works for
-              -- our purposes.
-              registration = Registration "globalFileWatches"
-                                          WorkspaceDidChangeWatchedFiles
-                                          (Just (A.toJSON regOptions))
-              regOptions =
-                DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
-              -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
-              watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
-              -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
-              -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
-              -- followed by a file with an extension 'hs'.
-              watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
-              -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
-              -- support that: https://github.com/bubba/lsp-test/issues/77
-              watchers = [ watcher glob | glob <- watchedGlobs opts ]
-
-            sendFunc $ LSP.ReqRegisterCapability req
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RankNTypes            #-}++module Development.IDE.LSP.Notifications+    ( setHandlersNotifications+    ) where++import           Development.IDE.LSP.Server+import qualified Language.Haskell.LSP.Core        as LSP+import           Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Types       as LSP+import qualified Language.Haskell.LSP.Messages    as LSP+import qualified Language.Haskell.LSP.Types.Capabilities as LSP++import           Development.IDE.Core.IdeConfiguration+import           Development.IDE.Core.Service+import           Development.IDE.Core.Shake+import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger+import           Development.IDE.Types.Options++import           Control.Monad.Extra+import qualified Data.Aeson                       as A+import           Data.Foldable                    as F+import           Data.Maybe+import qualified Data.HashMap.Strict              as M+import qualified Data.HashSet                     as S+import qualified Data.Text                        as Text++import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified, typecheckParents)+import           Development.IDE.Core.FileExists  (modifyFileExists, watchedGlobs)+import           Development.IDE.Core.OfInterest+import Ide.Plugin.Config (CheckParents(CheckOnClose))+++whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'++setHandlersNotifications :: PartialHandlers c+setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x+    {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $+        \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do+            updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])+            whenUriFile _uri $ \file -> do+                -- We don't know if the file actually exists, or if the contents match those on disk+                -- For example, vscode restores previously unsaved contents on open+                modifyFilesOfInterest ide (M.insert file Modified)+                setFileModified ide False file+                logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri++    ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $+        \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do+            updatePositionMapping ide identifier changes+            whenUriFile _uri $ \file -> do+              modifyFilesOfInterest ide (M.insert file Modified)+              setFileModified ide False file+            logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri++    ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $+        \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do+            whenUriFile _uri $ \file -> do+                modifyFilesOfInterest ide (M.insert file OnDisk)+                setFileModified ide True file+            logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri++    ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $+        \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do+            whenUriFile _uri $ \file -> do+                modifyFilesOfInterest ide (M.delete file)+                -- Refresh all the files that depended on this+                IdeOptions{optCheckParents} <- getIdeOptionsIO $ shakeExtras ide+                when (optCheckParents >= CheckOnClose) $ typecheckParents ide file+                logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri+    ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $+        \_ ide (DidChangeWatchedFilesParams fileEvents) -> do+            -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and+            -- what we do with them+            let events =+                    mapMaybe+                        (\(FileEvent uri ev) ->+                            (, ev /= FcDeleted) . toNormalizedFilePath'+                            <$> LSP.uriToFilePath uri+                        )+                        ( F.toList fileEvents )+            let msg = Text.pack $ show events+            logDebug (ideLogger ide) $ "Files created or deleted: " <> msg+            modifyFileExists ide events+            setSomethingModified ide++    ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $+        \_ ide (DidChangeWorkspaceFoldersParams events) -> do+            let add       = S.union+                substract = flip S.difference+            modifyWorkspaceFolders ide+              $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))+              . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))++    ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $+        \_ ide (DidChangeConfigurationParams cfg) -> do+            let msg = Text.pack $ show cfg+            logInfo (ideLogger ide) $ "Configuration changed: " <> msg+            modifyClientSettings ide (const $ Just cfg)+            setSomethingModified ide++    -- Initialized handler, good time to dynamically register capabilities+    ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do+        let watchSupported = case () of+              _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities+                , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+                , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+                , Just True <- _dynamicRegistration+                  -> True+                | otherwise -> False++        if watchSupported+        then registerWatcher lsp ide+        else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"++    }+    where+        registerWatcher LSP.LspFuncs{..} ide = do+            lspId <- getNextReqId+            opts <- getIdeOptionsIO $ shakeExtras ide+            let+              req = RequestMessage "2.0" lspId ClientRegisterCapability regParams+              regParams    = RegistrationParams (List [registration])+              -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).+              -- We could also use something like a random UUID, as some other servers do, but this works for+              -- our purposes.+              registration = Registration "globalFileWatches"+                                          WorkspaceDidChangeWatchedFiles+                                          (Just (A.toJSON regOptions))+              regOptions =+                DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }+              -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind+              watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}+              -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is+              -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,+              -- followed by a file with an extension 'hs'.+              watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }+              -- We use multiple watchers instead of one using '{}' because lsp-test doesn't+              -- support that: https://github.com/bubba/lsp-test/issues/77+              watchers = [ watcher glob | glob <- watchedGlobs opts ]++            sendFunc $ LSP.ReqRegisterCapability req
src/Development/IDE/LSP/Outline.hs view
@@ -1,230 +1,230 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-#include "ghc-api-version.h"
-
-module Development.IDE.LSP.Outline
-  ( setHandlersOutline
-    -- * For haskell-language-server
-  , moduleOutline
-  )
-where
-
-import qualified Language.Haskell.LSP.Core     as LSP
-import           Language.Haskell.LSP.Messages
-import           Language.Haskell.LSP.Types
-import           Data.Functor
-import           Data.Generics
-import           Data.Maybe
-import           Data.Text                      ( Text
-                                                , pack
-                                                )
-import qualified Data.Text                     as T
-import           Development.IDE.Core.Rules
-import           Development.IDE.Core.Shake
-import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Error      ( realSrcSpanToRange )
-import           Development.IDE.LSP.Server
-import           Development.IDE.Types.Location
-import           Outputable                     ( Outputable
-                                                , ppr
-                                                , showSDocUnsafe
-                                                )
-
-setHandlersOutline :: PartialHandlers c
-setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
-  { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline
-  }
-
-moduleOutline
-  :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
-moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
-  = case uriToFilePath uri of
-    Just (toNormalizedFilePath' -> fp) -> do
-      mb_decls <- fmap fst <$> runIdeAction "Outline" (shakeExtras ideState) (useWithStaleFast GetParsedModule fp)
-      pure $ Right $ case mb_decls of
-        Nothing -> DSDocumentSymbols (List [])
-        Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }
-          -> let
-               declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls
-               moduleSymbol = hsmodName >>= \case
-                 (L (RealSrcSpan l) m) -> Just $
-                   (defDocumentSymbol l :: DocumentSymbol)
-                     { _name  = pprText m
-                     , _kind  = SkFile
-                     , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0
-                     }
-                 _ -> Nothing
-               importSymbols = maybe [] pure $
-                  documentSymbolForImportSummary
-                    (mapMaybe documentSymbolForImport hsmodImports)
-               allSymbols    = case moduleSymbol of
-                 Nothing -> importSymbols <> declSymbols
-                 Just x ->
-                   [ x { _children = Just (List (importSymbols <> declSymbols))
-                       }
-                   ]
-             in
-               DSDocumentSymbols (List allSymbols)
-
-
-    Nothing -> pure $ Right $ DSDocumentSymbols (List [])
-
-documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol
-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))
-  = Just (defDocumentSymbol l :: DocumentSymbol)
-    { _name   = showRdrName n
-                  <> (case pprText fdTyVars of
-                       "" -> ""
-                       t  -> " " <> t
-                     )
-    , _detail = Just $ pprText fdInfo
-    , _kind   = SkClass
-    }
-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))
-  = Just (defDocumentSymbol l :: DocumentSymbol)
-    { _name     = showRdrName name
-                    <> (case pprText tcdTyVars of
-                         "" -> ""
-                         t  -> " " <> t
-                       )
-    , _kind     = SkClass
-    , _detail   = Just "class"
-    , _children =
-      Just $ List
-        [ (defDocumentSymbol l :: DocumentSymbol)
-            { _name           = showRdrName n
-            , _kind           = SkMethod
-            , _selectionRange = realSrcSpanToRange l'
-            }
-        | L (RealSrcSpan l)  (ClassOpSig _ False names _) <- tcdSigs
-        , L (RealSrcSpan l') n                            <- names
-        ]
-    }
-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))
-  = Just (defDocumentSymbol l :: DocumentSymbol)
-    { _name     = showRdrName name
-    , _kind     = SkStruct
-    , _children =
-      Just $ List
-        [ (defDocumentSymbol l :: DocumentSymbol)
-            { _name           = showRdrName n
-            , _kind           = SkConstructor
-            , _selectionRange = realSrcSpanToRange l'
-            , _children       = conArgRecordFields (getConArgs x)
-            }
-        | L (RealSrcSpan l ) x <- dd_cons
-        , L (RealSrcSpan l') n <- getConNames x
-        ]
-    }
-  where
-    -- | Extract the record fields of a constructor
-    conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List
-      [ (defDocumentSymbol l :: DocumentSymbol)
-          { _name = showRdrName n
-          , _kind = SkField
-          }
-      | L _ cdf <- lcdfs
-      , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf
-      ]
-    conArgRecordFields _ = Nothing
-documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just
-  (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n
-                                          , _kind           = SkTypeParameter
-                                          , _selectionRange = realSrcSpanToRange l'
-                                          }
-documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))
-  = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
-                                                 , _kind = SkInterface
-                                                 }
-documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
-  = Just (defDocumentSymbol l :: DocumentSymbol)
-    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
-                (map pprText feqn_pats)
-    , _kind = SkInterface
-    }
-documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
-  = Just (defDocumentSymbol l :: DocumentSymbol)
-    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
-                (map pprText feqn_pats)
-    , _kind = SkInterface
-    }
-documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) =
-  gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->
-    (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)
-                                              name
-                                            , _kind = SkInterface
-                                            }
-documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just
-    (defDocumentSymbol l :: DocumentSymbol)
-      { _name   = showRdrName name
-      , _kind   = SkFunction
-      }
-documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just
-    (defDocumentSymbol l :: DocumentSymbol)
-      { _name   = pprText pat_lhs
-      , _kind   = SkFunction
-      }
-
-documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just
-  (defDocumentSymbol l :: DocumentSymbol)
-    { _name   = case x of
-                  ForeignImport{} -> name
-                  ForeignExport{} -> name
-                  XForeignDecl{}  -> "?"
-    , _kind   = SkObject
-    , _detail = case x of
-                  ForeignImport{} -> Just "import"
-                  ForeignExport{} -> Just "export"
-                  XForeignDecl{}  -> Nothing
-    }
-  where name = showRdrName $ unLoc $ fd_name x
-
-documentSymbolForDecl _ = Nothing
-
--- | Wrap the Document imports into a hierarchical outline for
--- a better overview of symbols in scope.
--- If there are no imports, then no hierarchy will be created.
-documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol
-documentSymbolForImportSummary [] = Nothing
-documentSymbolForImportSummary importSymbols =
-    let
-      -- safe because if we have no ranges then we don't take this branch
-      mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)
-      importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols
-    in
-      Just (defDocumentSymbol empty :: DocumentSymbol)
-          { _name = "imports"
-          , _kind = SkModule
-          , _children = Just (List importSymbols)
-          , _range = importRange
-          , _selectionRange = importRange
-          }
-
-documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol
-documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just
-  (defDocumentSymbol l :: DocumentSymbol)
-    { _name   = "import " <> pprText ideclName
-    , _kind   = SkModule
-#if MIN_GHC_API_VERSION(8,10,0)
-    , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }
-#else
-    , _detail = if ideclQualified then Just "qualified" else Nothing
-#endif
-    }
-documentSymbolForImport _ = Nothing
-
-defDocumentSymbol :: RealSrcSpan -> DocumentSymbol
-defDocumentSymbol l = DocumentSymbol { .. } where
-  _detail         = Nothing
-  _deprecated     = Nothing
-  _name           = ""
-  _kind           = SkUnknown 0
-  _range          = realSrcSpanToRange l
-  _selectionRange = realSrcSpanToRange l
-  _children       = Nothing
-
-showRdrName :: RdrName -> Text
-showRdrName = pprText
-
-pprText :: Outputable a => a -> Text
-pprText = pack . showSDocUnsafe . ppr
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+#include "ghc-api-version.h"++module Development.IDE.LSP.Outline+  ( setHandlersOutline+    -- * For haskell-language-server+  , moduleOutline+  )+where++import qualified Language.Haskell.LSP.Core     as LSP+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types+import           Data.Functor+import           Data.Generics+import           Data.Maybe+import           Data.Text                      ( Text+                                                , pack+                                                )+import qualified Data.Text                     as T+import           Development.IDE.Core.Rules+import           Development.IDE.Core.Shake+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Error      ( realSrcSpanToRange )+import           Development.IDE.LSP.Server+import           Development.IDE.Types.Location+import           Outputable                     ( Outputable+                                                , ppr+                                                , showSDocUnsafe+                                                )++setHandlersOutline :: PartialHandlers c+setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x+  { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline+  }++moduleOutline+  :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)+moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }+  = case uriToFilePath uri of+    Just (toNormalizedFilePath' -> fp) -> do+      mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp)+      pure $ Right $ case mb_decls of+        Nothing -> DSDocumentSymbols (List [])+        Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }+          -> let+               declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls+               moduleSymbol = hsmodName >>= \case+                 (L (RealSrcSpan l) m) -> Just $+                   (defDocumentSymbol l :: DocumentSymbol)+                     { _name  = pprText m+                     , _kind  = SkFile+                     , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0+                     }+                 _ -> Nothing+               importSymbols = maybe [] pure $+                  documentSymbolForImportSummary+                    (mapMaybe documentSymbolForImport hsmodImports)+               allSymbols    = case moduleSymbol of+                 Nothing -> importSymbols <> declSymbols+                 Just x ->+                   [ x { _children = Just (List (importSymbols <> declSymbols))+                       }+                   ]+             in+               DSDocumentSymbols (List allSymbols)+++    Nothing -> pure $ Right $ DSDocumentSymbols (List [])++documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol+documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name   = showRdrName n+                  <> (case pprText fdTyVars of+                       "" -> ""+                       t  -> " " <> t+                     )+    , _detail = Just $ pprText fdInfo+    , _kind   = SkClass+    }+documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name     = showRdrName name+                    <> (case pprText tcdTyVars of+                         "" -> ""+                         t  -> " " <> t+                       )+    , _kind     = SkClass+    , _detail   = Just "class"+    , _children =+      Just $ List+        [ (defDocumentSymbol l :: DocumentSymbol)+            { _name           = showRdrName n+            , _kind           = SkMethod+            , _selectionRange = realSrcSpanToRange l'+            }+        | L (RealSrcSpan l)  (ClassOpSig _ False names _) <- tcdSigs+        , L (RealSrcSpan l') n                            <- names+        ]+    }+documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name     = showRdrName name+    , _kind     = SkStruct+    , _children =+      Just $ List+        [ (defDocumentSymbol l :: DocumentSymbol)+            { _name           = showRdrName n+            , _kind           = SkConstructor+            , _selectionRange = realSrcSpanToRange l'+            , _children       = conArgRecordFields (getConArgs x)+            }+        | L (RealSrcSpan l ) x <- dd_cons+        , L (RealSrcSpan l') n <- getConNames x+        ]+    }+  where+    -- | Extract the record fields of a constructor+    conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List+      [ (defDocumentSymbol l :: DocumentSymbol)+          { _name = showRdrName n+          , _kind = SkField+          }+      | L _ cdf <- lcdfs+      , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf+      ]+    conArgRecordFields _ = Nothing+documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just+  (defDocumentSymbol l :: DocumentSymbol) { _name           = showRdrName n+                                          , _kind           = SkTypeParameter+                                          , _selectionRange = realSrcSpanToRange l'+                                          }+documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))+  = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty+                                                 , _kind = SkInterface+                                                 }+documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords+                (map pprText feqn_pats)+    , _kind = SkInterface+    }+documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+  = Just (defDocumentSymbol l :: DocumentSymbol)+    { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords+                (map pprText feqn_pats)+    , _kind = SkInterface+    }+documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) =+  gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->+    (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)+                                              name+                                            , _kind = SkInterface+                                            }+documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just+    (defDocumentSymbol l :: DocumentSymbol)+      { _name   = showRdrName name+      , _kind   = SkFunction+      }+documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just+    (defDocumentSymbol l :: DocumentSymbol)+      { _name   = pprText pat_lhs+      , _kind   = SkFunction+      }++documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just+  (defDocumentSymbol l :: DocumentSymbol)+    { _name   = case x of+                  ForeignImport{} -> name+                  ForeignExport{} -> name+                  XForeignDecl{}  -> "?"+    , _kind   = SkObject+    , _detail = case x of+                  ForeignImport{} -> Just "import"+                  ForeignExport{} -> Just "export"+                  XForeignDecl{}  -> Nothing+    }+  where name = showRdrName $ unLoc $ fd_name x++documentSymbolForDecl _ = Nothing++-- | Wrap the Document imports into a hierarchical outline for+-- a better overview of symbols in scope.+-- If there are no imports, then no hierarchy will be created.+documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol+documentSymbolForImportSummary [] = Nothing+documentSymbolForImportSummary importSymbols =+    let+      -- safe because if we have no ranges then we don't take this branch+      mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)+      importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols+    in+      Just (defDocumentSymbol empty :: DocumentSymbol)+          { _name = "imports"+          , _kind = SkModule+          , _children = Just (List importSymbols)+          , _range = importRange+          , _selectionRange = importRange+          }++documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol+documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just+  (defDocumentSymbol l :: DocumentSymbol)+    { _name   = "import " <> pprText ideclName+    , _kind   = SkModule+#if MIN_GHC_API_VERSION(8,10,0)+    , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }+#else+    , _detail = if ideclQualified then Just "qualified" else Nothing+#endif+    }+documentSymbolForImport _ = Nothing++defDocumentSymbol :: RealSrcSpan -> DocumentSymbol+defDocumentSymbol l = DocumentSymbol { .. } where+  _detail         = Nothing+  _deprecated     = Nothing+  _name           = ""+  _kind           = SkUnknown 0+  _range          = realSrcSpanToRange l+  _selectionRange = realSrcSpanToRange l+  _children       = Nothing++showRdrName :: RdrName -> Text+showRdrName = pprText++pprText :: Outputable a => a -> Text+pprText = pack . showSDocUnsafe . ppr
src/Development/IDE/LSP/Protocol.hs view
@@ -1,23 +1,23 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-{-# LANGUAGE PatternSynonyms #-}
-
-module Development.IDE.LSP.Protocol
-    ( pattern EventFileDiagnostics
-    ) where
-
-import Development.IDE.Types.Diagnostics
-import Development.IDE.Types.Location
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-
-----------------------------------------------------------------------------------------------------
--- Pretty printing
-----------------------------------------------------------------------------------------------------
-
--- | Pattern synonym to make it a bit more convenient to match on diagnostics
--- in things like damlc test.
-pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage
-pattern EventFileDiagnostics fp diags <-
-    NotPublishDiagnostics
-        (NotificationMessage _ _ (PublishDiagnosticsParams (uriToFilePath' -> Just fp) (List diags)))
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE PatternSynonyms #-}++module Development.IDE.LSP.Protocol+    ( pattern EventFileDiagnostics+    ) where++import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types++----------------------------------------------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------------------------------------------++-- | Pattern synonym to make it a bit more convenient to match on diagnostics+-- in things like damlc test.+pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage+pattern EventFileDiagnostics fp diags <-+    NotPublishDiagnostics+        (NotificationMessage _ _ (PublishDiagnosticsParams (uriToFilePath' -> Just fp) (List diags)))
src/Development/IDE/LSP/Server.hs view
@@ -1,47 +1,47 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE RankNTypes #-}
-module Development.IDE.LSP.Server
-  ( WithMessage(..)
-  , PartialHandlers(..)
-  ) where
-
-
-import Data.Default
-
-import           Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Core as LSP
-import qualified Language.Haskell.LSP.Messages as LSP
-import Development.IDE.Core.Service
-
-data WithMessage c = WithMessage
-    {withResponse :: forall m req resp . (Show m, Show req) =>
-        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
-        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
-        Maybe (LSP.Handler (RequestMessage m req resp))
-    ,withNotification :: forall m req . (Show m, Show req) =>
-        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
-        (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
-        Maybe (LSP.Handler (NotificationMessage m req))
-    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
-        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
-        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
-        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
-        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
-        Maybe (LSP.Handler (RequestMessage m req resp))
-    , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
-                     -> Maybe (LSP.Handler InitializeRequest)
-    }
-
-newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)
-
-instance Default (PartialHandlers c) where
-    def = PartialHandlers $ \_ x -> pure x
-
-instance Semigroup (PartialHandlers c) where
-    PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
-
-instance Monoid (PartialHandlers c) where
-    mempty = def
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RankNTypes #-}+module Development.IDE.LSP.Server+  ( WithMessage(..)+  , PartialHandlers(..)+  ) where+++import Data.Default++import           Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Core as LSP+import qualified Language.Haskell.LSP.Messages as LSP+import Development.IDE.Core.Service++data WithMessage c = WithMessage+    {withResponse :: forall m req resp . (Show m, Show req) =>+        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response+        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work+        Maybe (LSP.Handler (RequestMessage m req resp))+    ,withNotification :: forall m req . (Show m, Show req) =>+        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler+        (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work+        Maybe (LSP.Handler (NotificationMessage m req))+    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .+        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>+        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response+        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req+        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work+        Maybe (LSP.Handler (RequestMessage m req resp))+    , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())+                     -> Maybe (LSP.Handler InitializeRequest)+    }++newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)++instance Default (PartialHandlers c) where+    def = PartialHandlers $ \_ x -> pure x++instance Semigroup (PartialHandlers c) where+    PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w++instance Monoid (PartialHandlers c) where+    mempty = def
src/Development/IDE/Plugin.hs view
@@ -1,57 +1,57 @@-module Development.IDE.Plugin
-  ( Plugin(..)
-  , codeActionPlugin
-  , codeActionPluginWithRules
-  , makeLspCommandId
-  ) where
-
-import Data.Default
-import qualified Data.Text as T
-import Development.Shake
-import Development.IDE.LSP.Server
-import Development.IDE.Core.Rules
-import Ide.PluginUtils
-import           Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Core as LSP
-import Language.Haskell.LSP.Messages
-
-
-data Plugin c = Plugin
-    {pluginRules :: Rules ()
-    ,pluginHandler :: PartialHandlers c
-    }
-
-instance Default (Plugin c) where
-    def = Plugin mempty def
-
-instance Semigroup (Plugin c) where
-    Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)
-
-instance Monoid (Plugin c) where
-    mempty = def
-
-
-codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
-codeActionPlugin = codeActionPluginWithRules mempty
-
-codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
-codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.codeActionHandler = withResponse RspCodeAction g
-    }
-    where
-      g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
-
--- | Prefix to uniquely identify commands sent to the client.  This
--- has two parts
---
--- - A representation of the process id to make sure that a client has
---   unique commands if it is running multiple servers, since some
---   clients have a global command table and get confused otherwise.
---
--- - A string to identify ghcide, to ease integration into
---   haskell-language-server, which routes commands to plugins based
---   on that.
-makeLspCommandId :: T.Text -> IO T.Text
-makeLspCommandId command = do
-    pid <- getProcessID
-    return $ T.pack (show pid) <> ":ghcide:" <> command
+module Development.IDE.Plugin+  ( Plugin(..)+  , codeActionPlugin+  , codeActionPluginWithRules+  , makeLspCommandId+  ) where++import Data.Default+import qualified Data.Text as T+import Development.Shake+import Development.IDE.LSP.Server+import Development.IDE.Core.Rules+import Ide.PluginUtils+import           Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Messages+++data Plugin c = Plugin+    {pluginRules :: Rules ()+    ,pluginHandler :: PartialHandlers c+    }++instance Default (Plugin c) where+    def = Plugin mempty def++instance Semigroup (Plugin c) where+    Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)++instance Monoid (Plugin c) where+    mempty = def+++codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c+codeActionPlugin = codeActionPluginWithRules mempty++codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.codeActionHandler = withResponse RspCodeAction g+    }+    where+      g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c++-- | Prefix to uniquely identify commands sent to the client.  This+-- has two parts+--+-- - A representation of the process id to make sure that a client has+--   unique commands if it is running multiple servers, since some+--   clients have a global command table and get confused otherwise.+--+-- - A string to identify ghcide, to ease integration into+--   haskell-language-server, which routes commands to plugins based+--   on that.+makeLspCommandId :: T.Text -> IO T.Text+makeLspCommandId command = do+    pid <- getProcessID+    return $ T.pack (show pid) <> ":ghcide:" <> command
src/Development/IDE/Plugin/CodeAction.hs view
@@ -1,1184 +1,1234 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE CPP                   #-}
-#include "ghc-api-version.h"
-
--- | Go to the definition of a variable.
-module Development.IDE.Plugin.CodeAction
-    (
-      plugin
-
-    -- * For haskell-language-server
-    , codeAction
-    , codeLens
-    , rulePackageExports
-    , commandHandler
-
-    -- * For testing
-    , blockCommandId
-    , typeSignatureCommandId
-    , matchRegExMultipleImports
-    ) where
-
-import Control.Monad (join, guard)
-import Development.IDE.Plugin
-import Development.IDE.GHC.Compat
-import Development.IDE.Core.Rules
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Core.Service
-import Development.IDE.Core.Shake
-import Development.IDE.GHC.Error
-import Development.IDE.LSP.Server
-import Development.IDE.Plugin.CodeAction.PositionIndexed
-import Development.IDE.Plugin.CodeAction.RuleTypes
-import Development.IDE.Plugin.CodeAction.Rules
-import Development.IDE.Types.Exports
-import Development.IDE.Types.Location
-import Development.IDE.Types.Options
-import Development.Shake (Rules)
-import qualified Data.HashMap.Strict as Map
-import qualified Language.Haskell.LSP.Core as LSP
-import Language.Haskell.LSP.VFS
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import qualified Data.Rope.UTF16 as Rope
-import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
-import Data.Char
-import Data.Maybe
-import Data.List.Extra
-import qualified Data.Text as T
-import Text.Regex.TDFA (mrAfter, (=~), (=~~))
-import Outputable (ppr, showSDocUnsafe)
-import Data.Function
-import Control.Arrow ((>>>))
-import Data.Functor
-import Control.Applicative ((<|>))
-import Safe (atMay)
-import Bag (isEmptyBag)
-import qualified Data.HashSet as Set
-import Control.Concurrent.Extra (threadDelay, readVar)
-
-plugin :: Plugin c
-plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
-
-rules :: Rules ()
-rules = rulePackageExports
-
--- | a command that blocks forever. Used for testing
-blockCommandId :: T.Text
-blockCommandId = "ghcide.command.block"
-
-typeSignatureCommandId :: T.Text
-typeSignatureCommandId = "typesignature.add"
-
--- | Generate code actions.
-codeAction
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> TextDocumentIdentifier
-    -> Range
-    -> CodeActionContext
-    -> IO (Either ResponseError [CAResult])
-codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
-        mbFile = toNormalizedFilePath' <$> uriToFilePath uri
-    diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state
-    (ideOptions, join -> parsedModule, join -> env) <- runAction "CodeAction" state $
-      (,,) <$> getIdeOptions
-            <*> getParsedModule `traverse` mbFile
-            <*> use GhcSession `traverse` mbFile
-    -- This is quite expensive 0.6-0.7s on GHC
-    pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env
-    localExports <- readVar (exportsMap $ shakeExtras state)
-    let exportsMap = localExports <> fromMaybe mempty pkgExports
-    pure . Right $
-        [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
-        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text x
-        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
-        ] <> caRemoveRedundantImports parsedModule text diag xs uri
-
--- | Generate code lenses.
-codeLens
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> CodeLensParams
-    -> IO (Either ResponseError (List CodeLens))
-codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
-    commandId <- makeLspCommandId "typesignature.add"
-    fmap (Right . List) $ case uriToFilePath' uri of
-      Just (toNormalizedFilePath' -> filePath) -> do
-        _ <- runAction "codeLens" ideState (use TypeCheck filePath)
-        diag <- getDiagnostics ideState
-        hDiag <- getHiddenDiagnostics ideState
-        pure
-          [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
-          | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
-          , dFile == filePath
-          , (title, tedit) <- suggestSignature False dDiag
-          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
-          ]
-      Nothing -> pure []
-
--- | Execute the "typesignature.add" command.
-commandHandler
-    :: LSP.LspFuncs c
-    -> IdeState
-    -> ExecuteCommandParams
-    -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
-commandHandler lsp _ideState ExecuteCommandParams{..}
-    -- _command is prefixed with a process ID, because certain clients
-    -- have a global command registry, and all commands must be
-    -- unique. And there can be more than one ghcide instance running
-    -- at a time against the same client.
-    | T.isSuffixOf blockCommandId _command
-    = do
-        LSP.sendFunc lsp $ NotCustomServer $
-            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
-        threadDelay maxBound
-        return (Right Null, Nothing)
-    | T.isSuffixOf typeSignatureCommandId _command
-    , Just (List [edit]) <- _arguments
-    , Success wedit <- fromJSON edit
-    = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
-    | otherwise
-    = return (Right Null, Nothing)
-
-suggestAction
-  :: ExportsMap
-  -> IdeOptions
-  -> Maybe ParsedModule
-  -> Maybe T.Text
-  -> Diagnostic
-  -> [(T.Text, [TextEdit])]
-suggestAction packageExports ideOptions parsedModule text diag = concat
-   -- Order these suggestions by priority
-    [ suggestSignature True diag
-    , suggestExtendImport packageExports text diag
-    , suggestFillTypeWildcard diag
-    , suggestFixConstructorImport text diag
-    , suggestModuleTypo diag
-    , suggestReplaceIdentifier text diag
-    , removeRedundantConstraints text diag
-    , suggestAddTypeAnnotationToSatisfyContraints text diag
-    ] ++ concat
-    [  suggestConstraint pm text diag
-    ++ suggestNewDefinition ideOptions pm text diag
-    ++ suggestNewImport packageExports pm diag
-    ++ suggestDeleteUnusedBinding pm text diag
-    ++ suggestExportUnusedTopBinding text pm diag
-    | Just pm <- [parsedModule]
-    ] ++
-    suggestFillHole diag                   -- Lowest priority
-
-
-suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
---     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
-    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
-    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports
-    , Just c <- contents
-    , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
-    , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
-    , not (null ranges')
-    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
-
--- File.hs:16:1: warning:
---     The import of `Data.List' is redundant
---       except perhaps to import instances from `Data.List'
---     To import instances alone, use: import Data.List()
-    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
-        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
-    | otherwise = []
-
-caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult]
-caRemoveRedundantImports m contents digs ctxDigs uri
-  | Just pm <- m,
-    r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs,
-    allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],
-    caRemoveAll <- removeAll allEdits,
-    ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs],
-    not $ null ctxEdits,
-    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits
-      = caRemoveCtx ++ [caRemoveAll]
-  | otherwise = []
-  where
-    removeSingle title tedit diagnostic = CACodeAction CodeAction{..} where
-        _changes = Just $ Map.singleton uri $ List tedit
-        _title = title
-        _kind = Just CodeActionQuickFix
-        _diagnostics = Just $ List [diagnostic]
-        _documentChanges = Nothing
-        _edit = Just WorkspaceEdit{..}
-        _command = Nothing
-    removeAll tedit = CACodeAction CodeAction {..} where
-        _changes = Just $ Map.singleton uri $ List tedit
-        _title = "Remove all redundant imports"
-        _kind = Just CodeActionQuickFix
-        _diagnostics = Nothing
-        _documentChanges = Nothing
-        _edit = Just WorkspaceEdit{..}
-        _command = Nothing
-
-suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestDeleteUnusedBinding
-  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}
-  contents
-  Diagnostic{_range=_range,..}
--- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’
-    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"
-    , Just indexedContent <- indexedByPosition . T.unpack <$> contents
-      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)
-        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])
-    | otherwise = []
-    where
-      relatedRanges indexedContent name =
-        concatMap (findRelatedSpans indexedContent name) hsmodDecls
-      toRange = realSrcSpanToRange
-      extendForSpaces = extendToIncludePreviousNewlineIfPossible
-
-      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]
-      findRelatedSpans
-        indexedContent
-        name
-        (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =
-        case lname of
-          (L nLoc _name) | isTheBinding nLoc ->
-            let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig
-                findSig _ = []
-            in
-              [extendForSpaces indexedContent $ toRange l]
-              ++ concatMap findSig hsmodDecls
-          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches
-      findRelatedSpans _ _ _ = []
-
-      extractNameAndMatchesFromFunBind
-        :: HsBind GhcPs
-        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])
-      extractNameAndMatchesFromFunBind
-        FunBind
-          { fun_id=lname
-          , fun_matches=MG {mg_alts=L _ matches}
-          } = Just (lname, matches)
-      extractNameAndMatchesFromFunBind _ = Nothing
-
-      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]
-      findRelatedSigSpan indexedContent name l sig =
-        let maybeSpan = findRelatedSigSpan1 name sig
-        in case maybeSpan of
-          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int
-          Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused
-          _ -> []
-
-      -- Second of the tuple means there is only one match
-      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)
-      findRelatedSigSpan1 name (TypeSig _ lnames _) =
-        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames
-        in case maybeIdx of
-            Nothing -> Nothing
-            Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True)
-            Just idx ->
-              let targetLname = getLoc $ lnames !! idx
-                  startLoc = srcSpanStart targetLname
-                  endLoc = srcSpanEnd targetLname
-                  startLoc' = if idx == 0
-                              then startLoc
-                              else srcSpanEnd . getLoc $ lnames !! (idx - 1)
-                  endLoc' = if idx == 0 && idx < length lnames - 1
-                            then srcSpanStart . getLoc $ lnames !! (idx + 1)
-                            else endLoc
-              in Just (mkSrcSpan startLoc' endLoc', False)
-      findRelatedSigSpan1 _ _ = Nothing
-
-      -- for where clause
-      findRelatedSpanForMatch
-        :: PositionIndexedString
-        -> String
-        -> LMatch GhcPs (LHsExpr GhcPs)
-        -> [Range]
-      findRelatedSpanForMatch
-        indexedContent
-        name
-        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do
-        case grhssLocalBinds of
-          (L _ (HsValBinds _ (ValBinds _ bag lsigs))) ->
-            if isEmptyBag bag
-            then []
-            else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag
-          _ -> []
-      findRelatedSpanForMatch _ _ _ = []
-
-      findRelatedSpanForHsBind
-        :: PositionIndexedString
-        -> String
-        -> [LSig GhcPs]
-        -> LHsBind GhcPs
-        -> [Range]
-      findRelatedSpanForHsBind
-        indexedContent
-        name
-        lsigs
-        (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =
-        if isTheBinding (getLoc lname)
-        then
-          let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig
-              findSig _ = []
-          in [extendForSpaces indexedContent $ toRange l] ++ concatMap findSig lsigs
-        else concatMap (findRelatedSpanForMatch indexedContent name) matches
-      findRelatedSpanForHsBind _ _ _ _ = []
-
-      isTheBinding :: SrcSpan -> Bool
-      isTheBinding span = srcSpanToRange span == Just _range
-
-      isSameName :: IdP GhcPs -> String -> Bool
-      isSameName x name = showSDocUnsafe (ppr x) == name
-
-data ExportsAs = ExportName | ExportPattern | ExportAll
-  deriving (Eq)
-
-suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}
--- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’
--- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’
--- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’
-  | Just source <- srcOpt
-  , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"
-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"
-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"
-  , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)
-                            . mapMaybe
-                                (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l
-                                                then exportsAs b else Nothing)
-                            $ hsmodDecls
-  , Just pos <- fmap _end . getLocatedRange =<< hsmodExports
-  , Just needComma <- needsComma source <$> hsmodExports
-  , let exportName = (if needComma then "," else "") <> printExport exportType name
-        insertPos = pos {_character = pred $ _character pos}
-  = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]
-  | otherwise = []
-  where
-    -- we get the last export and the closing bracket and check for comma in that range
-    needsComma :: T.Text -> Located [LIE GhcPs] -> Bool
-    needsComma _ (L _ []) = False
-    needsComma source (L (RealSrcSpan l) exports) =
-      let closeParan = _end $ realSrcSpanToRange l
-          lastExport = fmap _end . getLocatedRange $ last exports
-      in case lastExport of
-        Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source
-        _ -> False
-    needsComma _ _ = False
-
-    opLetter :: String
-    opLetter = ":!#$%&*+./<=>?@\\^|-~"
-
-    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text
-    parenthesizeIfNeeds needsTypeKeyword x
-      | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"
-      | otherwise = x
-
-    getLocatedRange :: Located a -> Maybe Range
-    getLocatedRange = srcSpanToRange . getLoc
-
-    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool
-    matchWithDiagnostic Range{_start=l,_end=r} x =
-      let loc = fmap _start . getLocatedRange $ x
-       in loc >= Just l && loc <= Just r
-
-    printExport :: ExportsAs -> T.Text -> T.Text
-    printExport ExportName x = parenthesizeIfNeeds False x
-    printExport ExportPattern x = "pattern " <> x
-    printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)"
-
-    isTopLevel :: Range -> Bool
-    isTopLevel l = (_character . _start) l == 0
-
-    exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p))
-    exportsAs (ValD _ FunBind {fun_id})          = Just (ExportName, fun_id)
-    exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id)
-    exportsAs (TyClD _ SynDecl{tcdLName})      = Just (ExportName, tcdLName)
-    exportsAs (TyClD _ DataDecl{tcdLName})     = Just (ExportAll, tcdLName)
-    exportsAs (TyClD _ ClassDecl{tcdLName})    = Just (ExportAll, tcdLName)
-    exportsAs (TyClD _ FamDecl{tcdFam})        = Just (ExportAll, fdLName tcdFam)
-    exportsAs _                                = Nothing
-
-suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}
--- File.hs:52:41: warning:
---     * Defaulting the following constraint to type ‘Integer’
---        Num p0 arising from the literal ‘1’
---     * In the expression: 1
---       In an equation for ‘f’: f = 1
--- File.hs:52:41: warning:
---     * Defaulting the following constraints to type ‘[Char]’
---        (Show a0)
---          arising from a use of ‘traceShow’
---          at A.hs:228:7-25
---        (IsString a0)
---          arising from the literal ‘"debug"’
---          at A.hs:228:17-23
---     * In the expression: traceShow "debug" a
---       In an equation for ‘f’: f a = traceShow "debug" a
--- File.hs:52:41: warning:
---     * Defaulting the following constraints to type ‘[Char]’
---         (Show a0)
---          arising from a use of ‘traceShow’
---          at A.hs:255:28-43
---        (IsString a0)
---          arising from the literal ‘"test"’
---          at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43
---     * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’
---       In the expression: seq "test" seq "test" (traceShow "test")
---       In an equation for ‘f’:
---          f = seq "test" seq "test" (traceShow "test")
-    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True)
-                        <|> matchRegexUnifySpaces _message (pat False False False)
-            = codeEdit ty lit (makeAnnotatedLit ty lit)
-    | Just source <- sourceOpt
-    , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False)
-            = let lit' = makeAnnotatedLit ty lit;
-                  tir = textInRange _range source
-              in codeEdit ty lit (T.replace lit lit' tir)
-    | otherwise = []
-    where
-      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"
-      pat multiple at inThe = T.concat [ ".*Defaulting the following constraint"
-                                       , if multiple then "s" else ""
-                                       , " to type ‘([^ ]+)’ "
-                                       , ".*arising from the literal ‘(.+)’"
-                                       , if inThe then ".+In the.+argument" else ""
-                                       , if at then ".+at" else ""
-                                       , ".+In the expression"
-                                       ]
-      codeEdit ty lit replacement =
-        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"
-            edits = [TextEdit _range replacement]
-        in  [( title, edits )]
-
-
-suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
--- File.hs:52:41: error:
---     * Variable not in scope:
---         suggestAcion :: Maybe T.Text -> Range -> Range
---     * Perhaps you meant ‘suggestAction’ (line 83)
--- File.hs:94:37: error:
---     Not in scope: ‘T.isPrfixOf’
---     Perhaps you meant one of these:
---       ‘T.isPrefixOf’ (imported from Data.Text),
---       ‘T.isInfixOf’ (imported from Data.Text),
---       ‘T.isSuffixOf’ (imported from Data.Text)
---     Module ‘Data.Text’ does not export ‘isPrfixOf’.
-    | renameSuggestions@(_:_) <- extractRenamableTerms _message
-        = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
-    | otherwise = []
-
-suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}
---     * Variable not in scope:
---         suggestAcion :: Maybe T.Text -> Range -> Range
-    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
-    = newDefinitionAction ideOptions parsedModule _range name typ
-    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
-    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
-    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
-    | otherwise = []
-    where
-      message = unifySpaces _message
-
-newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
-newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
-    | Range _ lastLineP : _ <-
-      [ realSrcSpanToRange sp
-      | (L l@(RealSrcSpan sp) _) <- hsmodDecls
-      , _start `isInsideSrcSpan` l]
-    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
-    = [ ("Define " <> sig
-        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
-        )]
-    | otherwise = []
-  where
-    colon = if optNewColonConvention then " : " else " :: "
-    sig = name <> colon <> T.dropWhileEnd isSpace typ
-    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
-
-
-suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
-suggestFillTypeWildcard Diagnostic{_range=_range,..}
--- Foo.hs:3:8: error:
---     * Found type wildcard `_' standing for `p -> p1 -> p'
-
-    | "Found type wildcard" `T.isInfixOf` _message
-    , " standing for " `T.isInfixOf` _message
-    , typeSignature <- extractWildCardTypeSignature _message
-        =  [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
-    | otherwise = []
-
-suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
-suggestModuleTypo Diagnostic{_range=_range,..}
--- src/Development/IDE/Core/Compile.hs:58:1: error:
---     Could not find module ‘Data.Cha’
---     Perhaps you meant Data.Char (from base-4.12.0.0)
-    | "Could not find module" `T.isInfixOf` _message
-    , "Perhaps you meant"     `T.isInfixOf` _message = let
-      findSuggestedModules = map (head . T.words) . drop 2 . T.lines
-      proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
-      in map proposeModule $ nubOrd $ findSuggestedModules _message
-    | otherwise = []
-
-suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
-suggestFillHole Diagnostic{_range=_range,..}
-    | Just holeName <- extractHoleName _message
-    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message)
-    = map (proposeHoleFit holeName False) holeFits
-    ++ map (proposeHoleFit holeName True) refFits
-    | otherwise = []
-    where
-      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
-      proposeHoleFit holeName parenthise name =
-          ( "replace " <> holeName <> " with " <> name
-          , [TextEdit _range $ if parenthise then parens name else name])
-      parens x = "(" <> x <> ")"
-
-processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])
-processHoleSuggestions mm = (holeSuggestions, refSuggestions)
-{-
-    • Found hole: _ :: LSP.Handlers
-
-      Valid hole fits include def
-      Valid refinement hole fits include
-        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)
-        fromJust (_ :: Maybe LSP.Handlers)
-        haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams
-                                                                                                        LSP.Handlers)
-        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)
-                (_ :: LSP.Handlers)
-                (_ :: T.Text)
-        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)
-                 (_ :: LSP.Handlers)
-                 (_ :: T.Text)
--}
-  where
-    t = id @T.Text
-    holeSuggestions = do
-      -- get the text indented under Valid hole fits
-      validHolesSection <-
-        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm
-      -- the Valid hole fits line can contain a hole fit
-      holeFitLine <-
-        mapHead
-            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))
-            validHolesSection
-      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine
-      guard (not $ T.null holeFit)
-      return holeFit
-    refSuggestions = do -- @[]
-      -- get the text indented under Valid refinement hole fits
-      refinementSection <-
-        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm
-      -- get the text for each hole fit
-      holeFitLines <- getIndentedGroups (tail refinementSection)
-      let holeFit = T.strip $ T.unwords holeFitLines
-      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"
-      return holeFit
-
-    mapHead f (a:aa) = f a : aa
-    mapHead _ [] = []
-
--- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]
-getIndentedGroups :: [T.Text] -> [[T.Text]]
-getIndentedGroups [] = []
-getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll
--- |
--- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]
-getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]
-getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
-    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of
-        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest
-    _ -> []
-
-indentation :: T.Text -> Int
-indentation = T.length . T.takeWhile isSpace
-
-suggestExtendImport :: ExportsMap -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestExtendImport exportsMap contents Diagnostic{_range=_range,..}
-    | Just [binding, mod, srcspan] <-
-      matchRegexUnifySpaces _message
-      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
-    , Just c <- contents
-    = suggestions c binding mod srcspan
-    | Just (binding, mod_srcspan) <-
-      matchRegExMultipleImports _message
-    , Just c <- contents
-    = mod_srcspan >>= (\(x, y) -> suggestions c binding x y)
-    | otherwise = []
-    where
-        suggestions c binding mod srcspan
-          |  range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
-                [s] -> let x = realSrcSpanToRange s
-                   in x{_end = (_end x){_character = succ (_character (_end x))}}
-                _ -> error "bug in srcspan parser",
-            importLine <- textInRange range c,
-            Just ident <- lookupExportMap binding mod,
-            Just result <- addBindingToImportList ident importLine
-            = [("Add " <> renderIdentInfo ident <> " to the import list of " <> mod, [TextEdit range result])]
-          | otherwise = []
-        lookupExportMap binding mod
-          | Just match <- Map.lookup binding (getExportsMap exportsMap)
-          , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match)
-           = Just ident
-
-            -- fallback to using GHC suggestion even though it is not always correct
-          | otherwise
-          = Just IdentInfo
-                { name = binding
-                , rendered = binding
-                , parent = Nothing
-                , isDatacon = False}
-
-suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestFixConstructorImport _ Diagnostic{_range=_range,..}
-    -- ‘Success’ is a data constructor of ‘Result’
-    -- To import it use
-    -- import Data.Aeson.Types( Result( Success ) )
-    -- or
-    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)
-  | Just [constructor, typ] <-
-    matchRegexUnifySpaces _message
-    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
-  = let fixedImport = typ <> "(" <> constructor <> ")"
-    in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
-  | otherwise = []
-
-suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
-    | _message =~
-      ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
-      signature      = removeInitialForAll
-                     $ T.takeWhile (\x -> x/='*' && x/='•')
-                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
-      startOfLine    = Position (_line _start) startCharacter
-      beforeLine     = Range startOfLine startOfLine
-      title          = if isQuickFix then "add signature: " <> signature else signature
-      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
-      in [(title, [action])]
-    where removeInitialForAll :: T.Text -> T.Text
-          removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
-              | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
-              | otherwise                  = nm <> ty
-          startCharacter
-            | "Polymorphic local binding" `T.isPrefixOf` _message
-            = _character _start
-            | otherwise
-            = 0
-
-suggestSignature _ _ = []
-
--- | Suggests a constraint for a declaration for which a constraint is missing.
-suggestConstraint :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestConstraint parsedModule mContents diag@Diagnostic {..}
-  | Just contents <- mContents
-  , Just missingConstraint <- findMissingConstraint _message
-  = let codeAction = if _message =~ ("the type signature for:" :: String)
-                        then suggestFunctionConstraint parsedModule
-                        else suggestInstanceConstraint contents
-     in codeAction diag missingConstraint
-  | otherwise = []
-    where
-      findMissingConstraint :: T.Text -> Maybe T.Text
-      findMissingConstraint t =
-        let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of"
-         in matchRegexUnifySpaces t regex <&> last
-
-normalizeConstraints :: T.Text -> T.Text -> T.Text
-normalizeConstraints existingConstraints constraint =
-  let constraintsInit = if "(" `T.isPrefixOf` existingConstraints
-                           then T.dropEnd 1 existingConstraints
-                           else "(" <> existingConstraints
-   in constraintsInit <> ", " <> constraint <> ")"
-
--- | Suggests a constraint for an instance declaration for which a constraint is missing.
-suggestInstanceConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]
-suggestInstanceConstraint contents Diagnostic {..} missingConstraint
--- Suggests a constraint for an instance declaration with no existing constraints.
--- • No instance for (Eq a) arising from a use of ‘==’
---   Possible fix: add (Eq a) to the context of the instance declaration
--- • In the expression: x == y
---   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y
---   In the instance declaration for ‘Eq (Wrap a)’
-  | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"
-  = let instanceLine = contents
-          & T.splitOn ("instance " <> instanceDeclaration)
-          & head & T.lines & length
-        startOfConstraint = Position instanceLine (length ("instance " :: String))
-        range = Range startOfConstraint startOfConstraint
-        newConstraint = missingConstraint <> " => "
-     in [(actionTitle missingConstraint, [TextEdit range newConstraint])]
-
--- Suggests a constraint for an instance declaration with one or more existing constraints.
--- • Could not deduce (Eq b) arising from a use of ‘==’
---   from the context: Eq a
---     bound by the instance declaration at /path/to/Main.hs:7:10-32
---   Possible fix: add (Eq b) to the context of the instance declaration
--- • In the second argument of ‘(&&)’, namely ‘x' == y'’
---   In the expression: x == y && x' == y'
---   In an equation for ‘==’:
---       (Pair x x') == (Pair y y') = x == y && x' == y'
-  | Just [instanceLineStr, constraintFirstCharStr]
-    <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"
-  = let existingConstraints = findExistingConstraints _message
-        newConstraints = normalizeConstraints existingConstraints missingConstraint
-        instanceLine = readPositionNumber instanceLineStr
-        constraintFirstChar = readPositionNumber constraintFirstCharStr
-        startOfConstraint = Position instanceLine constraintFirstChar
-        endOfConstraint = Position instanceLine $
-          constraintFirstChar + T.length existingConstraints
-        range = Range startOfConstraint endOfConstraint
-     in [(actionTitle missingConstraint, [TextEdit range newConstraints])]
-  | otherwise = []
-    where
-      findExistingConstraints :: T.Text -> T.Text
-      findExistingConstraints t =
-        T.replace "from the context: " "" . T.strip $ T.lines t !! 1
-
-      readPositionNumber :: T.Text -> Int
-      readPositionNumber = T.unpack >>> read >>> pred
-
-      actionTitle :: T.Text -> T.Text
-      actionTitle constraint = "Add `" <> constraint
-        <> "` to the context of the instance declaration"
-
-findTypeSignatureName :: T.Text -> Maybe T.Text
-findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head
-
-findTypeSignatureLine :: T.Text -> T.Text -> Int
-findTypeSignatureLine contents typeSignatureName =
-  T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length
-
--- | Suggests a constraint for a type signature with any number of existing constraints.
-suggestFunctionConstraint :: ParsedModule -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]
-suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{..} missingConstraint
--- • No instance for (Eq a) arising from a use of ‘==’
---   Possible fix:
---     add (Eq a) to the context of
---       the type signature for:
---         eq :: forall a. a -> a -> Bool
--- • In the expression: x == y
---   In an equation for ‘eq’: eq x y = x == y
-
--- • Could not deduce (Eq b) arising from a use of ‘==’
---   from the context: Eq a
---     bound by the type signature for:
---                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool
---     at Main.hs:5:1-42
---   Possible fix:
---     add (Eq b) to the context of
---       the type signature for:
---         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool
--- • In the second argument of ‘(&&)’, namely ‘y == y'’
---   In the expression: x == x' && y == y'
---   In an equation for ‘eq’:
---       eq (Pair x y) (Pair x' y') = x == x' && y == y'
-  | Just typeSignatureName <- findTypeSignatureName _message
-  = let mExistingConstraints = findExistingConstraints _message
-        newConstraint = buildNewConstraints missingConstraint mExistingConstraints
-     in case findRangeOfContextForFunctionNamed typeSignatureName of
-       Just range -> [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])]
-       Nothing -> []
-  | otherwise = []
-    where
-      findRangeOfContextForFunctionNamed :: T.Text -> Maybe Range
-      findRangeOfContextForFunctionNamed typeSignatureName = do
-          locatedType <- listToMaybe
-              [ locatedType
-              | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls
-              , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers
-              ]
-          srcSpanToRange $ case splitLHsQualTy locatedType of
-            (L contextSrcSpan _ , _) ->
-              if isGoodSrcSpan contextSrcSpan
-                then contextSrcSpan -- The type signature has explicit context
-                else -- No explicit context, return SrcSpan at the start of type sig where we can write context
-                     let start = srcSpanStart $ getLoc locatedType in mkSrcSpan start start
-
-      isSameName :: IdP GhcPs -> String -> Bool
-      isSameName x name = showSDocUnsafe (ppr x) == name
-
-      findExistingConstraints :: T.Text -> Maybe T.Text
-      findExistingConstraints message =
-        if message =~ ("from the context:" :: String)
-           then fmap (T.strip . head) $ matchRegexUnifySpaces message "\\. ([^=]+)"
-           else Nothing
-
-      buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text
-      buildNewConstraints constraint mExistingConstraints =
-        case mExistingConstraints of
-          Just existingConstraints -> normalizeConstraints existingConstraints constraint
-          Nothing -> constraint <> " => "
-
-      actionTitle :: T.Text -> T.Text -> T.Text
-      actionTitle constraint typeSignatureName = "Add `" <> constraint
-        <> "` to the context of the type signature for `" <> typeSignatureName <> "`"
-
--- | Suggests the removal of a redundant constraint for a type signature.
-removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-removeRedundantConstraints mContents Diagnostic{..}
--- • Redundant constraint: Eq a
--- • In the type signature for:
---      foo :: forall a. Eq a => a -> a
--- • Redundant constraints: (Monoid a, Show a)
--- • In the type signature for:
---      foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool
-  | Just contents <- mContents
-  -- Account for both "Redundant constraint" and "Redundant constraints".
-  , True <- "Redundant constraint" `T.isInfixOf` _message
-  , Just typeSignatureName <- findTypeSignatureName _message
-  , Just redundantConstraintList <- findRedundantConstraints _message
-  , Just constraints <- findConstraints contents typeSignatureName
-  = let constraintList = parseConstraints constraints
-        newConstraints = buildNewConstraints constraintList redundantConstraintList
-        typeSignatureLine = findTypeSignatureLine contents typeSignatureName
-        typeSignatureFirstChar = T.length $ typeSignatureName <> " :: "
-        startOfConstraint = Position typeSignatureLine typeSignatureFirstChar
-        endOfConstraint = Position typeSignatureLine $
-          typeSignatureFirstChar + T.length (constraints <> " => ")
-        range = Range startOfConstraint endOfConstraint
-     in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])]
-  | otherwise = []
-    where
-      parseConstraints :: T.Text -> [T.Text]
-      parseConstraints t = t
-        & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")
-        <&> T.strip
-
-      stripConstraintsParens :: T.Text -> T.Text
-      stripConstraintsParens constraints =
-        if "(" `T.isPrefixOf` constraints
-           then constraints & T.drop 1 & T.dropEnd 1 & T.strip
-           else constraints
-
-      findRedundantConstraints :: T.Text -> Maybe [T.Text]
-      findRedundantConstraints t = t
-        & T.lines
-        & head
-        & T.strip
-        & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)")
-        <&> (head >>> parseConstraints)
-
-      -- If the type signature is not formatted as expected (arbitrary number of spaces,
-      -- line feeds...), just fail.
-      findConstraints :: T.Text -> T.Text -> Maybe T.Text
-      findConstraints contents typeSignatureName = do
-        constraints <- contents
-          & T.splitOn (typeSignatureName <> " :: ")
-          & (`atMay` 1)
-          >>= (T.splitOn " => " >>> (`atMay` 0))
-        guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints
-        return constraints
-
-      formatConstraints :: [T.Text] -> T.Text
-      formatConstraints [] = ""
-      formatConstraints [constraint] = constraint
-      formatConstraints constraintList = constraintList
-        & T.intercalate ", "
-        & \cs -> "(" <> cs <> ")"
-
-      formatConstraintsWithArrow :: [T.Text] -> T.Text
-      formatConstraintsWithArrow [] = ""
-      formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ")
-
-      buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text
-      buildNewConstraints constraintList redundantConstraintList =
-        formatConstraintsWithArrow $ constraintList \\ redundantConstraintList
-
-      actionTitle :: [T.Text] -> T.Text -> T.Text
-      actionTitle constraintList typeSignatureName =
-        "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `"
-        <> formatConstraints constraintList
-        <> "` from the context of the type signature for `" <> typeSignatureName <> "`"
-
--------------------------------------------------------------------------------------------------
-
-suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
-  | msg <- unifySpaces _message
-  , Just thingMissing <- extractNotInScopeName msg
-  , qual <- extractQualifiedModuleName msg
-  , Just insertLine <- case hsmodImports of
-        [] -> case srcSpanStart $ getLoc (head hsmodDecls) of
-          RealSrcLoc s -> Just $ srcLocLine s - 1
-          _ -> Nothing
-        _ -> case srcSpanEnd $ getLoc (last hsmodImports) of
-          RealSrcLoc s -> Just $ srcLocLine s
-          _ -> Nothing
-  , insertPos <- Position insertLine 0
-  , extendImportSuggestions <- matchRegexUnifySpaces msg
-    "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
-  = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
-    | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions
-    ]
-suggestNewImport _ _ _ = []
-
-constructNewImportSuggestions
-  :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [T.Text]
-constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd
-  [ suggestion
-  | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing]
-  , (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)
-  , canUseIdent thingMissing identInfo
-  , m `notElem` fromMaybe [] notTheseModules
-  , suggestion <- renderNewImport identInfo m
-  ]
- where
-  renderNewImport identInfo m
-    | Just q <- qual
-    , asQ <- if q == m then "" else " as " <> q
-    = ["import qualified " <> m <> asQ]
-    | otherwise
-    = ["import " <> m <> " (" <> renderIdentInfo identInfo <> ")"
-      ,"import " <> m ]
-
-canUseIdent :: NotInScope -> IdentInfo -> Bool
-canUseIdent NotInScopeDataConstructor{} = isDatacon
-canUseIdent _                           = const True
-
-data NotInScope
-    = NotInScopeDataConstructor T.Text
-    | NotInScopeTypeConstructorOrClass T.Text
-    | NotInScopeThing T.Text
-    deriving Show
-
-notInScope :: NotInScope -> T.Text
-notInScope (NotInScopeDataConstructor t) = t
-notInScope (NotInScopeTypeConstructorOrClass t) = t
-notInScope (NotInScopeThing t) = t
-
-extractNotInScopeName :: T.Text -> Maybe NotInScope
-extractNotInScopeName x
-  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"
-  = Just $ NotInScopeDataConstructor name
-  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"
-  = Just $ NotInScopeDataConstructor name
-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
-  = Just $ NotInScopeTypeConstructorOrClass name
-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"
-  = Just $ NotInScopeThing name
-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"
-  = Just $ NotInScopeThing name
-  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"
-  = Just $ NotInScopeThing name
-  | otherwise
-  = Nothing
-
-extractQualifiedModuleName :: T.Text -> Maybe T.Text
-extractQualifiedModuleName x
-  | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"
-  = Just m
-  | otherwise
-  = Nothing
-
--------------------------------------------------------------------------------------------------
-
-
-mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
-mkRenameEdit contents range name =
-    if maybeIsInfixFunction == Just True
-      then TextEdit range ("`" <> name <> "`")
-      else TextEdit range name
-  where
-    maybeIsInfixFunction = do
-      curr <- textInRange range <$> contents
-      pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
-
-extractWildCardTypeSignature :: T.Text -> T.Text
-extractWildCardTypeSignature =
-  -- inferring when parens are actually needed around the type signature would
-  -- require understanding both the precedence of the context of the _ and of
-  -- the signature itself. Inserting them unconditionally is ugly but safe.
-  ("(" `T.append`) . (`T.append` ")") .
-  T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
-  snd . T.breakOnEnd "standing for "
-
-extractRenamableTerms :: T.Text -> [T.Text]
-extractRenamableTerms msg
-  -- Account for both "Variable not in scope" and "Not in scope"
-  | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
-  | otherwise = []
-  where
-    extractSuggestions = map getEnclosed
-                       . concatMap singleSuggestions
-                       . filter isKnownSymbol
-                       . T.lines
-    singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited
-    isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
-    getEnclosed = T.dropWhile (== '‘')
-                . T.dropWhileEnd (== '’')
-                . T.dropAround (\c -> c /= '‘' && c /= '’')
-
--- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace
--- between the end of the range and the next newline), extend the range to take up the whole line.
-extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
-extendToWholeLineIfPossible contents range@Range{..} =
-    let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
-        extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
-    in if extend then Range _start (Position (_line _end + 1) 0) else range
-
-splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
-splitTextAtPosition (Position row col) x
-    | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
-    , (preCol, postCol) <- T.splitAt col mid
-        = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
-    | otherwise = (x, T.empty)
-
--- | Returns [start .. end[
-textInRange :: Range -> T.Text -> T.Text
-textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
-    case compare startRow endRow of
-      LT ->
-        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
-            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
-              [] -> ("", [])
-              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
-            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
-        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
-      EQ ->
-        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
-        in T.take (endCol - startCol) (T.drop startCol line)
-      GT -> ""
-    where
-      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
-
--- | Returns the ranges for a binding in an import declaration
-rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
-rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
-    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies
-  where
-    b' = wrapOperatorInParens (unqualify b)
-
-    wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
-
-    unqualify x = snd $ breakOnEnd "." x
-
-rangesForBinding _ _ = []
-
-rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
-rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
-rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
-rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l]
-rangesForBinding' b (L l (IEThingWith _ thing _  inners labels))
-    | showSDocUnsafe (ppr thing) == b = [l]
-    | otherwise =
-        [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
-        [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
-rangesForBinding' _ _ = []
-
--- | Extends an import list with a new binding.
---   Assumes an import statement of the form:
---       import (qualified) A (..) ..
---   Places the new binding first, preserving whitespace.
---   Copes with multi-line import lists
-addBindingToImportList :: IdentInfo -> T.Text -> Maybe T.Text
-addBindingToImportList IdentInfo {parent = _parent, ..} importLine =
-  case T.breakOn "(" importLine of
-    (pre, T.uncons -> Just (_, rest)) ->
-      case _parent of
-        -- the binding is not a constructor, add it to the head of import list
-        Nothing -> Just $ T.concat [pre, "(", rendered, addCommaIfNeeds rest]
-        Just parent -> case T.breakOn parent rest of
-          -- the binding is a constructor, and current import list contains its parent
-          -- `rest'` could be 1. `,...)`
-          --               or 2. `(),...)`
-          --               or 3. `(ConsA),...)`
-          --               or 4. `)`
-          (leading, T.stripPrefix parent -> Just rest') -> case T.uncons (T.stripStart rest') of
-            -- case 1: no children and parentheses, e.g. `import A(Foo,...)` --> `import A(Foo(Cons), ...)`
-            Just (',', rest'') -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", addCommaIfNeeds rest'']
-            -- case 2: no children but parentheses, e.g. `import A(Foo(),...)` --> `import A(Foo(Cons), ...)`
-            Just ('(', T.uncons -> Just (')', rest'')) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest'']
-            -- case 3: children with parentheses, e.g. `import A(Foo(ConsA),...)` --> `import A(Foo(Cons, ConsA), ...)`
-            Just ('(', T.breakOn ")" -> (children, rest''))
-              | not (T.null children),
-                -- ignore A(Foo({-...-}), ...)
-                not $ "{-" `T.isPrefixOf` T.stripStart children
-              -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ", ", children, rest'']
-            -- case 4: no trailing, e.g. `import A(..., Foo)` --> `import A(..., Foo(Cons))`
-            Just (')', _) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest']
-            _ -> Nothing
-          -- current import list does not contain the parent, e.g. `import A(...)` --> `import A(Foo(Cons), ...)`
-          _ -> Just $ T.concat [pre, "(", parent, "(", rendered, ")", addCommaIfNeeds rest]
-    _ -> Nothing
-  where
-    addCommaIfNeeds r = case T.uncons (T.stripStart r) of
-      Just (')', _) -> r
-      _ -> ", " <> r
-
--- | 'matchRegex' combined with 'unifySpaces'
-matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]
-matchRegexUnifySpaces message = matchRegex (unifySpaces message)
-
--- | Returns Just (the submatches) for the first capture, or Nothing.
-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
-matchRegex message regex = case message =~~ regex of
-    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
-    Nothing -> Nothing
-
-setHandlersCodeLens :: PartialHandlers c
-setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.codeLensHandler =
-        withResponse RspCodeLens codeLens,
-    LSP.executeCommandHandler =
-        withResponseAndRequest
-            RspExecuteCommand
-            ReqApplyWorkspaceEdit
-            commandHandler
-    }
-
-filterNewlines :: T.Text -> T.Text
-filterNewlines = T.concat  . T.lines
-
-unifySpaces :: T.Text -> T.Text
-unifySpaces    = T.unwords . T.words
-
--- functions to help parse multiple import suggestions
-
--- | Returns the first match if found
-regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text
-regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of
-    Just (h:_) -> Just h
-    _ -> Nothing
-
--- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and
--- | return (Data.Map, app/ModuleB.hs:2:1-18)
-regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)
-regExPair (modname, srcpair) = do
-  x <- regexSingleMatch modname "‘([^’]*)’"
-  y <- regexSingleMatch srcpair "\\((.*)\\)"
-  return (x, y)
-
--- | Process a list of (module_name, filename:src_span) values
--- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]
-regExImports :: T.Text -> Maybe [(T.Text, T.Text)]
-regExImports msg = result
-  where
-    parts = T.words msg
-    isPrefix = not . T.isPrefixOf "("
-    (mod, srcspan) = partition isPrefix  parts
-    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))
-    result = if length mod == length srcspan then
-               regExPair `traverse` zip mod srcspan
-             else Nothing
-
-matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])
-matchRegExMultipleImports message = do
-  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"
-  (binding, imports) <- case matchRegexUnifySpaces message pat of
-                            Just [x, xs] -> Just (x, xs)
-                            _ -> Nothing
-  imps <- regExImports imports
-  return (binding, imps)
-
-renderIdentInfo :: IdentInfo -> T.Text
-renderIdentInfo IdentInfo {parent, rendered}
-  | Just p <- parent = p <> "(" <> rendered <> ")"
-  | otherwise        = rendered
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE CPP                   #-}+#include "ghc-api-version.h"++-- | Go to the definition of a variable.+module Development.IDE.Plugin.CodeAction+    (+      plugin++    -- * For haskell-language-server+    , codeAction+    , codeLens+    , rulePackageExports+    , commandHandler++    -- * For testing+    , blockCommandId+    , typeSignatureCommandId+    , matchRegExMultipleImports+    ) where++import Control.Monad (join, guard)+import Development.IDE.Plugin+import Development.IDE.GHC.Compat+import Development.IDE.Core.Rules+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Service+import Development.IDE.Core.Shake+import Development.IDE.GHC.Error+import Development.IDE.LSP.Server+import Development.IDE.Plugin.CodeAction.PositionIndexed+import Development.IDE.Plugin.CodeAction.RuleTypes+import Development.IDE.Plugin.CodeAction.Rules+import Development.IDE.Types.Exports+import Development.IDE.Types.Location+import Development.IDE.Types.Options+import Development.Shake (Rules)+import qualified Data.HashMap.Strict as Map+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.VFS+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import qualified Data.Rope.UTF16 as Rope+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))+import Data.Char+import Data.Maybe+import Data.List.Extra+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Text.Regex.TDFA (mrAfter, (=~), (=~~))+import Outputable (ppr, showSDocUnsafe)+import Data.Function+import Control.Arrow ((>>>))+import Data.Functor+import Control.Applicative ((<|>))+import Safe (atMay)+import Bag (isEmptyBag)+import qualified Data.HashSet as Set+import Control.Concurrent.Extra (threadDelay, readVar)++plugin :: Plugin c+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens++rules :: Rules ()+rules = rulePackageExports++-- | a command that blocks forever. Used for testing+blockCommandId :: T.Text+blockCommandId = "ghcide.command.block"++typeSignatureCommandId :: T.Text+typeSignatureCommandId = "typesignature.add"++-- | Generate code actions.+codeAction+    :: LSP.LspFuncs c+    -> IdeState+    -> TextDocumentIdentifier+    -> Range+    -> CodeActionContext+    -> IO (Either ResponseError [CAResult])+codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do+    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents+        mbFile = toNormalizedFilePath' <$> uriToFilePath uri+    diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state+    (ideOptions, join -> parsedModule, join -> env) <- runAction "CodeAction" state $+      (,,) <$> getIdeOptions+            <*> getParsedModule `traverse` mbFile+            <*> use GhcSession `traverse` mbFile+    -- This is quite expensive 0.6-0.7s on GHC+    pkgExports <- runAction "CodeAction:PackageExports" state $ (useNoFile_ . PackageExports) `traverse` env+    localExports <- readVar (exportsMap $ shakeExtras state)+    let exportsMap = localExports <> fromMaybe mempty pkgExports+    pure . Right $+        [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing+        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text x+        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing+        ] <> caRemoveRedundantImports parsedModule text diag xs uri++-- | Generate code lenses.+codeLens+    :: LSP.LspFuncs c+    -> IdeState+    -> CodeLensParams+    -> IO (Either ResponseError (List CodeLens))+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do+    commandId <- makeLspCommandId "typesignature.add"+    fmap (Right . List) $ case uriToFilePath' uri of+      Just (toNormalizedFilePath' -> filePath) -> do+        _ <- runAction "codeLens" ideState (use TypeCheck filePath)+        diag <- getDiagnostics ideState+        hDiag <- getHiddenDiagnostics ideState+        pure+          [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing+          | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag+          , dFile == filePath+          , (title, tedit) <- suggestSignature False dDiag+          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing+          ]+      Nothing -> pure []++-- | Execute the "typesignature.add" command.+commandHandler+    :: LSP.LspFuncs c+    -> IdeState+    -> ExecuteCommandParams+    -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+commandHandler lsp _ideState ExecuteCommandParams{..}+    -- _command is prefixed with a process ID, because certain clients+    -- have a global command registry, and all commands must be+    -- unique. And there can be more than one ghcide instance running+    -- at a time against the same client.+    | T.isSuffixOf blockCommandId _command+    = do+        LSP.sendFunc lsp $ NotCustomServer $+            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null+        threadDelay maxBound+        return (Right Null, Nothing)+    | T.isSuffixOf typeSignatureCommandId _command+    , Just (List [edit]) <- _arguments+    , Success wedit <- fromJSON edit+    = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))+    | otherwise+    = return (Right Null, Nothing)++suggestAction+  :: ExportsMap+  -> IdeOptions+  -> Maybe ParsedModule+  -> Maybe T.Text+  -> Diagnostic+  -> [(T.Text, [TextEdit])]+suggestAction packageExports ideOptions parsedModule text diag = concat+   -- Order these suggestions by priority+    [ suggestSignature True diag+    , suggestExtendImport packageExports text diag+    , suggestFillTypeWildcard diag+    , suggestFixConstructorImport text diag+    , suggestModuleTypo diag+    , suggestReplaceIdentifier text diag+    , removeRedundantConstraints text diag+    , suggestAddTypeAnnotationToSatisfyContraints text diag+    ] ++ concat+    [  suggestConstraint pm text diag+    ++ suggestNewDefinition ideOptions pm text diag+    ++ suggestNewImport packageExports pm diag+    ++ suggestDeleteUnusedBinding pm text diag+    ++ suggestExportUnusedTopBinding text pm diag+    | Just pm <- [parsedModule]+    ] +++    suggestFillHole diag                   -- Lowest priority+++suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}+--     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant+    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"+    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports+    , Just c <- contents+    , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)+    , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)+    , not (null ranges')+    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]++-- File.hs:16:1: warning:+--     The import of `Data.List' is redundant+--       except perhaps to import instances from `Data.List'+--     To import instances alone, use: import Data.List()+    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)+        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]+    | otherwise = []++caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult]+caRemoveRedundantImports m contents digs ctxDigs uri+  | Just pm <- m,+    r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs,+    allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],+    caRemoveAll <- removeAll allEdits,+    ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs],+    not $ null ctxEdits,+    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits+      = caRemoveCtx ++ [caRemoveAll]+  | otherwise = []+  where+    removeSingle title tedit diagnostic = CACodeAction CodeAction{..} where+        _changes = Just $ Map.singleton uri $ List tedit+        _title = title+        _kind = Just CodeActionQuickFix+        _diagnostics = Just $ List [diagnostic]+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        _command = Nothing+    removeAll tedit = CACodeAction CodeAction {..} where+        _changes = Just $ Map.singleton uri $ List tedit+        _title = "Remove all redundant imports"+        _kind = Just CodeActionQuickFix+        _diagnostics = Nothing+        _documentChanges = Nothing+        _edit = Just WorkspaceEdit{..}+        _command = Nothing++suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestDeleteUnusedBinding+  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}+  contents+  Diagnostic{_range=_range,..}+-- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’+    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+    , Just indexedContent <- indexedByPosition . T.unpack <$> contents+      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)+        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])+    | otherwise = []+    where+      relatedRanges indexedContent name =+        concatMap (findRelatedSpans indexedContent name) hsmodDecls+      toRange = realSrcSpanToRange+      extendForSpaces = extendToIncludePreviousNewlineIfPossible++      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]+      findRelatedSpans+        indexedContent+        name+        (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =+        case lname of+          (L nLoc _name) | isTheBinding nLoc ->+            let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig+                findSig _ = []+            in+              [extendForSpaces indexedContent $ toRange l]+              ++ concatMap findSig hsmodDecls+          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpans _ _ _ = []++      extractNameAndMatchesFromFunBind+        :: HsBind GhcPs+        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])+      extractNameAndMatchesFromFunBind+        FunBind+          { fun_id=lname+          , fun_matches=MG {mg_alts=L _ matches}+          } = Just (lname, matches)+      extractNameAndMatchesFromFunBind _ = Nothing++      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]+      findRelatedSigSpan indexedContent name l sig =+        let maybeSpan = findRelatedSigSpan1 name sig+        in case maybeSpan of+          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int+          Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused+          _ -> []++      -- Second of the tuple means there is only one match+      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)+      findRelatedSigSpan1 name (TypeSig _ lnames _) =+        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames+        in case maybeIdx of+            Nothing -> Nothing+            Just _ | length lnames == 1 -> Just (getLoc $ head lnames, True)+            Just idx ->+              let targetLname = getLoc $ lnames !! idx+                  startLoc = srcSpanStart targetLname+                  endLoc = srcSpanEnd targetLname+                  startLoc' = if idx == 0+                              then startLoc+                              else srcSpanEnd . getLoc $ lnames !! (idx - 1)+                  endLoc' = if idx == 0 && idx < length lnames - 1+                            then srcSpanStart . getLoc $ lnames !! (idx + 1)+                            else endLoc+              in Just (mkSrcSpan startLoc' endLoc', False)+      findRelatedSigSpan1 _ _ = Nothing++      -- for where clause+      findRelatedSpanForMatch+        :: PositionIndexedString+        -> String+        -> LMatch GhcPs (LHsExpr GhcPs)+        -> [Range]+      findRelatedSpanForMatch+        indexedContent+        name+        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do+        case grhssLocalBinds of+          (L _ (HsValBinds _ (ValBinds _ bag lsigs))) ->+            if isEmptyBag bag+            then []+            else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag+          _ -> []+      findRelatedSpanForMatch _ _ _ = []++      findRelatedSpanForHsBind+        :: PositionIndexedString+        -> String+        -> [LSig GhcPs]+        -> LHsBind GhcPs+        -> [Range]+      findRelatedSpanForHsBind+        indexedContent+        name+        lsigs+        (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =+        if isTheBinding (getLoc lname)+        then+          let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig+              findSig _ = []+          in [extendForSpaces indexedContent $ toRange l] ++ concatMap findSig lsigs+        else concatMap (findRelatedSpanForMatch indexedContent name) matches+      findRelatedSpanForHsBind _ _ _ _ = []++      isTheBinding :: SrcSpan -> Bool+      isTheBinding span = srcSpanToRange span == Just _range++      isSameName :: IdP GhcPs -> String -> Bool+      isSameName x name = showSDocUnsafe (ppr x) == name++data ExportsAs = ExportName | ExportPattern | ExportAll+  deriving (Eq)++suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]+suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}+-- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’+-- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’+-- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’+  | Just source <- srcOpt+  , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"+                   <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"+                   <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"+  , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)+                            . mapMaybe+                                (\(L l b) -> if maybe False isTopLevel $ srcSpanToRange l+                                                then exportsAs b else Nothing)+                            $ hsmodDecls+  , Just pos <- fmap _end . getLocatedRange =<< hsmodExports+  , Just needComma <- needsComma source <$> hsmodExports+  , let exportName = (if needComma then "," else "") <> printExport exportType name+        insertPos = pos {_character = pred $ _character pos}+  = [("Export ‘" <> name <> "’", [TextEdit (Range insertPos insertPos) exportName])]+  | otherwise = []+  where+    -- we get the last export and the closing bracket and check for comma in that range+    needsComma :: T.Text -> Located [LIE GhcPs] -> Bool+    needsComma _ (L _ []) = False+    needsComma source (L (RealSrcSpan l) exports) =+      let closeParan = _end $ realSrcSpanToRange l+          lastExport = fmap _end . getLocatedRange $ last exports+      in case lastExport of+        Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source+        _ -> False+    needsComma _ _ = False++    opLetter :: String+    opLetter = ":!#$%&*+./<=>?@\\^|-~"++    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text+    parenthesizeIfNeeds needsTypeKeyword x+      | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"+      | otherwise = x++    getLocatedRange :: Located a -> Maybe Range+    getLocatedRange = srcSpanToRange . getLoc++    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool+    matchWithDiagnostic Range{_start=l,_end=r} x =+      let loc = fmap _start . getLocatedRange $ x+       in loc >= Just l && loc <= Just r++    printExport :: ExportsAs -> T.Text -> T.Text+    printExport ExportName x = parenthesizeIfNeeds False x+    printExport ExportPattern x = "pattern " <> x+    printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)"++    isTopLevel :: Range -> Bool+    isTopLevel l = (_character . _start) l == 0++    exportsAs :: HsDecl p -> Maybe (ExportsAs, Located (IdP p))+    exportsAs (ValD _ FunBind {fun_id})          = Just (ExportName, fun_id)+    exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, psb_id)+    exportsAs (TyClD _ SynDecl{tcdLName})      = Just (ExportName, tcdLName)+    exportsAs (TyClD _ DataDecl{tcdLName})     = Just (ExportAll, tcdLName)+    exportsAs (TyClD _ ClassDecl{tcdLName})    = Just (ExportAll, tcdLName)+    exportsAs (TyClD _ FamDecl{tcdFam})        = Just (ExportAll, fdLName tcdFam)+    exportsAs _                                = Nothing++suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}+-- File.hs:52:41: warning:+--     * Defaulting the following constraint to type ‘Integer’+--        Num p0 arising from the literal ‘1’+--     * In the expression: 1+--       In an equation for ‘f’: f = 1+-- File.hs:52:41: warning:+--     * Defaulting the following constraints to type ‘[Char]’+--        (Show a0)+--          arising from a use of ‘traceShow’+--          at A.hs:228:7-25+--        (IsString a0)+--          arising from the literal ‘"debug"’+--          at A.hs:228:17-23+--     * In the expression: traceShow "debug" a+--       In an equation for ‘f’: f a = traceShow "debug" a+-- File.hs:52:41: warning:+--     * Defaulting the following constraints to type ‘[Char]’+--         (Show a0)+--          arising from a use of ‘traceShow’+--          at A.hs:255:28-43+--        (IsString a0)+--          arising from the literal ‘"test"’+--          at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43+--     * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’+--       In the expression: seq "test" seq "test" (traceShow "test")+--       In an equation for ‘f’:+--          f = seq "test" seq "test" (traceShow "test")+    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False)+                        <|> matchRegexUnifySpaces _message (pat False False False True)+                        <|> matchRegexUnifySpaces _message (pat False False False False)+            = codeEdit ty lit (makeAnnotatedLit ty lit)+    | Just source <- sourceOpt+    , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False)+            = let lit' = makeAnnotatedLit ty lit;+                  tir = textInRange _range source+              in codeEdit ty lit (T.replace lit lit' tir)+    | otherwise = []+    where+      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"+      pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint"+                                       , if multiple then "s" else ""+                                       , " to type ‘([^ ]+)’ "+                                       , ".*arising from the literal ‘(.+)’"+                                       , if inArg then ".+In the.+argument" else ""+                                       , if at then ".+at" else ""+                                       , if inExpr then ".+In the expression" else ""+                                       , ".+In the expression"+                                       ]+      codeEdit ty lit replacement =+        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"+            edits = [TextEdit _range replacement]+        in  [( title, edits )]+++suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}+-- File.hs:52:41: error:+--     * Variable not in scope:+--         suggestAcion :: Maybe T.Text -> Range -> Range+--     * Perhaps you meant ‘suggestAction’ (line 83)+-- File.hs:94:37: error:+--     Not in scope: ‘T.isPrfixOf’+--     Perhaps you meant one of these:+--       ‘T.isPrefixOf’ (imported from Data.Text),+--       ‘T.isInfixOf’ (imported from Data.Text),+--       ‘T.isSuffixOf’ (imported from Data.Text)+--     Module ‘Data.Text’ does not export ‘isPrfixOf’.+    | renameSuggestions@(_:_) <- extractRenamableTerms _message+        = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]+    | otherwise = []++suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}+--     * Variable not in scope:+--         suggestAcion :: Maybe T.Text -> Range -> Range+    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"+    = newDefinitionAction ideOptions parsedModule _range name typ+    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"+    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ+    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]+    | otherwise = []+    where+      message = unifySpaces _message++newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]+newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ+    | Range _ lastLineP : _ <-+      [ realSrcSpanToRange sp+      | (L l@(RealSrcSpan sp) _) <- hsmodDecls+      , _start `isInsideSrcSpan` l]+    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}+    = [ ("Define " <> sig+        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]+        )]+    | otherwise = []+  where+    colon = if optNewColonConvention then " : " else " :: "+    sig = name <> colon <> T.dropWhileEnd isSpace typ+    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule+++suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]+suggestFillTypeWildcard Diagnostic{_range=_range,..}+-- Foo.hs:3:8: error:+--     * Found type wildcard `_' standing for `p -> p1 -> p'++    | "Found type wildcard" `T.isInfixOf` _message+    , " standing for " `T.isInfixOf` _message+    , typeSignature <- extractWildCardTypeSignature _message+        =  [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]+    | otherwise = []++suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]+suggestModuleTypo Diagnostic{_range=_range,..}+-- src/Development/IDE/Core/Compile.hs:58:1: error:+--     Could not find module ‘Data.Cha’+--     Perhaps you meant Data.Char (from base-4.12.0.0)+    | "Could not find module" `T.isInfixOf` _message+    , "Perhaps you meant"     `T.isInfixOf` _message = let+      findSuggestedModules = map (head . T.words) . drop 2 . T.lines+      proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])+      in map proposeModule $ nubOrd $ findSuggestedModules _message+    | otherwise = []++suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]+suggestFillHole Diagnostic{_range=_range,..}+    | Just holeName <- extractHoleName _message+    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message)+    = map (proposeHoleFit holeName False) holeFits+    ++ map (proposeHoleFit holeName True) refFits+    | otherwise = []+    where+      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"+      proposeHoleFit holeName parenthise name =+          ( "replace " <> holeName <> " with " <> name+          , [TextEdit _range $ if parenthise then parens name else name])+      parens x = "(" <> x <> ")"++processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])+processHoleSuggestions mm = (holeSuggestions, refSuggestions)+{-+    • Found hole: _ :: LSP.Handlers++      Valid hole fits include def+      Valid refinement hole fits include+        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)+        fromJust (_ :: Maybe LSP.Handlers)+        haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams+                                                                                                        LSP.Handlers)+        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                (_ :: LSP.Handlers)+                (_ :: T.Text)+        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)+                 (_ :: LSP.Handlers)+                 (_ :: T.Text)+-}+  where+    t = id @T.Text+    holeSuggestions = do+      -- get the text indented under Valid hole fits+      validHolesSection <-+        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm+      -- the Valid hole fits line can contain a hole fit+      holeFitLine <-+        mapHead+            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))+            validHolesSection+      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine+      guard (not $ T.null holeFit)+      return holeFit+    refSuggestions = do -- @[]+      -- get the text indented under Valid refinement hole fits+      refinementSection <-+        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm+      -- get the text for each hole fit+      holeFitLines <- getIndentedGroups (tail refinementSection)+      let holeFit = T.strip $ T.unwords holeFitLines+      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"+      return holeFit++    mapHead f (a:aa) = f a : aa+    mapHead _ [] = []++-- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroups :: [T.Text] -> [[T.Text]]+getIndentedGroups [] = []+getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll+-- |+-- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]+getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]+getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of+    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of+        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest+    _ -> []++indentation :: T.Text -> Int+indentation = T.length . T.takeWhile isSpace++suggestExtendImport :: ExportsMap -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestExtendImport exportsMap contents Diagnostic{_range=_range,..}+    | Just [binding, mod, srcspan] <-+      matchRegexUnifySpaces _message+      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"+    , Just c <- contents+    = suggestions c binding mod srcspan+    | Just (binding, mod_srcspan) <-+      matchRegExMultipleImports _message+    , Just c <- contents+    = mod_srcspan >>= (\(x, y) -> suggestions c binding x y)+    | otherwise = []+    where+        suggestions c binding mod srcspan+          |  range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+                [s] -> let x = realSrcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+                _ -> error "bug in srcspan parser",+            importLine <- textInRange range c,+            Just ident <- lookupExportMap binding mod+          = [ ( "Add " <> rendered <> " to the import list of " <> mod+              , [TextEdit range result]+              )+            | importStyle <- NE.toList $ importStyles ident+            , let rendered = renderImportStyle importStyle+            , result <- maybeToList $ addBindingToImportList importStyle importLine]+          | otherwise = []+        lookupExportMap binding mod+          | Just match <- Map.lookup binding (getExportsMap exportsMap)+          , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match)+           = Just ident++            -- fallback to using GHC suggestion even though it is not always correct+          | otherwise+          = Just IdentInfo+                { name = binding+                , rendered = binding+                , parent = Nothing+                , isDatacon = False}++suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestFixConstructorImport _ Diagnostic{_range=_range,..}+    -- ‘Success’ is a data constructor of ‘Result’+    -- To import it use+    -- import Data.Aeson.Types( Result( Success ) )+    -- or+    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)+  | Just [constructor, typ] <-+    matchRegexUnifySpaces _message+    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"+  = let fixedImport = typ <> "(" <> constructor <> ")"+    in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]+  | otherwise = []++suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}+    | _message =~+      ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let+      signature      = removeInitialForAll+                     $ T.takeWhile (\x -> x/='*' && x/='•')+                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message+      startOfLine    = Position (_line _start) startCharacter+      beforeLine     = Range startOfLine startOfLine+      title          = if isQuickFix then "add signature: " <> signature else signature+      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "+      in [(title, [action])]+    where removeInitialForAll :: T.Text -> T.Text+          removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))+              | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))+              | otherwise                  = nm <> ty+          startCharacter+            | "Polymorphic local binding" `T.isPrefixOf` _message+            = _character _start+            | otherwise+            = 0++suggestSignature _ _ = []++-- | Suggests a constraint for a declaration for which a constraint is missing.+suggestConstraint :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestConstraint parsedModule mContents diag@Diagnostic {..}+  | Just contents <- mContents+  , Just missingConstraint <- findMissingConstraint _message+  = let codeAction = if _message =~ ("the type signature for:" :: String)+                        then suggestFunctionConstraint parsedModule+                        else suggestInstanceConstraint contents+     in codeAction diag missingConstraint+  | otherwise = []+    where+      findMissingConstraint :: T.Text -> Maybe T.Text+      findMissingConstraint t =+        let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from a use of"+         in matchRegexUnifySpaces t regex <&> last++normalizeConstraints :: T.Text -> T.Text -> T.Text+normalizeConstraints existingConstraints constraint =+  let constraintsInit = if "(" `T.isPrefixOf` existingConstraints+                           then T.dropEnd 1 existingConstraints+                           else "(" <> existingConstraints+   in constraintsInit <> ", " <> constraint <> ")"++-- | Suggests a constraint for an instance declaration for which a constraint is missing.+suggestInstanceConstraint :: T.Text -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]+suggestInstanceConstraint contents Diagnostic {..} missingConstraint+-- Suggests a constraint for an instance declaration with no existing constraints.+-- • No instance for (Eq a) arising from a use of ‘==’+--   Possible fix: add (Eq a) to the context of the instance declaration+-- • In the expression: x == y+--   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y+--   In the instance declaration for ‘Eq (Wrap a)’+  | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"+  = let instanceLine = contents+          & T.splitOn ("instance " <> instanceDeclaration)+          & head & T.lines & length+        startOfConstraint = Position instanceLine (length ("instance " :: String))+        range = Range startOfConstraint startOfConstraint+        newConstraint = missingConstraint <> " => "+     in [(actionTitle missingConstraint, [TextEdit range newConstraint])]++-- Suggests a constraint for an instance declaration with one or more existing constraints.+-- • Could not deduce (Eq b) arising from a use of ‘==’+--   from the context: Eq a+--     bound by the instance declaration at /path/to/Main.hs:7:10-32+--   Possible fix: add (Eq b) to the context of the instance declaration+-- • In the second argument of ‘(&&)’, namely ‘x' == y'’+--   In the expression: x == y && x' == y'+--   In an equation for ‘==’:+--       (Pair x x') == (Pair y y') = x == y && x' == y'+  | Just [instanceLineStr, constraintFirstCharStr]+    <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"+  = let existingConstraints = findExistingConstraints _message+        newConstraints = normalizeConstraints existingConstraints missingConstraint+        instanceLine = readPositionNumber instanceLineStr+        constraintFirstChar = readPositionNumber constraintFirstCharStr+        startOfConstraint = Position instanceLine constraintFirstChar+        endOfConstraint = Position instanceLine $+          constraintFirstChar + T.length existingConstraints+        range = Range startOfConstraint endOfConstraint+     in [(actionTitle missingConstraint, [TextEdit range newConstraints])]+  | otherwise = []+    where+      findExistingConstraints :: T.Text -> T.Text+      findExistingConstraints t =+        T.replace "from the context: " "" . T.strip $ T.lines t !! 1++      readPositionNumber :: T.Text -> Int+      readPositionNumber = T.unpack >>> read >>> pred++      actionTitle :: T.Text -> T.Text+      actionTitle constraint = "Add `" <> constraint+        <> "` to the context of the instance declaration"++findTypeSignatureName :: T.Text -> Maybe T.Text+findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head++findTypeSignatureLine :: T.Text -> T.Text -> Int+findTypeSignatureLine contents typeSignatureName =+  T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length++-- | Suggests a constraint for a type signature with any number of existing constraints.+suggestFunctionConstraint :: ParsedModule -> Diagnostic -> T.Text -> [(T.Text, [TextEdit])]+suggestFunctionConstraint ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} Diagnostic{..} missingConstraint+-- • No instance for (Eq a) arising from a use of ‘==’+--   Possible fix:+--     add (Eq a) to the context of+--       the type signature for:+--         eq :: forall a. a -> a -> Bool+-- • In the expression: x == y+--   In an equation for ‘eq’: eq x y = x == y++-- • Could not deduce (Eq b) arising from a use of ‘==’+--   from the context: Eq a+--     bound by the type signature for:+--                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool+--     at Main.hs:5:1-42+--   Possible fix:+--     add (Eq b) to the context of+--       the type signature for:+--         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool+-- • In the second argument of ‘(&&)’, namely ‘y == y'’+--   In the expression: x == x' && y == y'+--   In an equation for ‘eq’:+--       eq (Pair x y) (Pair x' y') = x == x' && y == y'+  | Just typeSignatureName <- findTypeSignatureName _message+  = let mExistingConstraints = findExistingConstraints _message+        newConstraint = buildNewConstraints missingConstraint mExistingConstraints+     in case findRangeOfContextForFunctionNamed typeSignatureName of+       Just range -> [(actionTitle missingConstraint typeSignatureName, [TextEdit range newConstraint])]+       Nothing -> []+  | otherwise = []+    where+      findRangeOfContextForFunctionNamed :: T.Text -> Maybe Range+      findRangeOfContextForFunctionNamed typeSignatureName = do+          locatedType <- listToMaybe+              [ locatedType+              | L _ (SigD _ (TypeSig _ identifiers (HsWC _ (HsIB _ locatedType)))) <- hsmodDecls+              , any (`isSameName` T.unpack typeSignatureName) $ fmap unLoc identifiers+              ]+          let typeBody = dropForAll locatedType+          srcSpanToRange $ case splitLHsQualTy typeBody of+            (L contextSrcSpan _ , _) ->+              if isGoodSrcSpan contextSrcSpan+                then contextSrcSpan -- The type signature has explicit context+                else -- No explicit context, return SrcSpan at the start of type (after a potential `forall`)+                    let start = srcSpanStart $ getLoc typeBody in mkSrcSpan start start++      isSameName :: IdP GhcPs -> String -> Bool+      isSameName x name = showSDocUnsafe (ppr x) == name++      findExistingConstraints :: T.Text -> Maybe T.Text+      findExistingConstraints message =+        if message =~ ("from the context:" :: String)+           then fmap (T.strip . head) $ matchRegexUnifySpaces message "\\. ([^=]+)"+           else Nothing++      buildNewConstraints :: T.Text -> Maybe T.Text -> T.Text+      buildNewConstraints constraint mExistingConstraints =+        case mExistingConstraints of+          Just existingConstraints -> normalizeConstraints existingConstraints constraint+          Nothing -> constraint <> " => "++      actionTitle :: T.Text -> T.Text -> T.Text+      actionTitle constraint typeSignatureName = "Add `" <> constraint+        <> "` to the context of the type signature for `" <> typeSignatureName <> "`"++-- | Suggests the removal of a redundant constraint for a type signature.+removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+removeRedundantConstraints mContents Diagnostic{..}+-- • Redundant constraint: Eq a+-- • In the type signature for:+--      foo :: forall a. Eq a => a -> a+-- • Redundant constraints: (Monoid a, Show a)+-- • In the type signature for:+--      foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool+  | Just contents <- mContents+  -- Account for both "Redundant constraint" and "Redundant constraints".+  , True <- "Redundant constraint" `T.isInfixOf` _message+  , Just typeSignatureName <- findTypeSignatureName _message+  , Just redundantConstraintList <- findRedundantConstraints _message+  , Just constraints <- findConstraints contents typeSignatureName+  = let constraintList = parseConstraints constraints+        newConstraints = buildNewConstraints constraintList redundantConstraintList+        typeSignatureLine = findTypeSignatureLine contents typeSignatureName+        typeSignatureFirstChar = T.length $ typeSignatureName <> " :: "+        startOfConstraint = Position typeSignatureLine typeSignatureFirstChar+        endOfConstraint = Position typeSignatureLine $+          typeSignatureFirstChar + T.length (constraints <> " => ")+        range = Range startOfConstraint endOfConstraint+     in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])]+  | otherwise = []+    where+      parseConstraints :: T.Text -> [T.Text]+      parseConstraints t = t+        & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")+        <&> T.strip++      stripConstraintsParens :: T.Text -> T.Text+      stripConstraintsParens constraints =+        if "(" `T.isPrefixOf` constraints+           then constraints & T.drop 1 & T.dropEnd 1 & T.strip+           else constraints++      findRedundantConstraints :: T.Text -> Maybe [T.Text]+      findRedundantConstraints t = t+        & T.lines+        & head+        & T.strip+        & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)")+        <&> (head >>> parseConstraints)++      -- If the type signature is not formatted as expected (arbitrary number of spaces,+      -- line feeds...), just fail.+      findConstraints :: T.Text -> T.Text -> Maybe T.Text+      findConstraints contents typeSignatureName = do+        constraints <- contents+          & T.splitOn (typeSignatureName <> " :: ")+          & (`atMay` 1)+          >>= (T.splitOn " => " >>> (`atMay` 0))+        guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints+        return constraints++      formatConstraints :: [T.Text] -> T.Text+      formatConstraints [] = ""+      formatConstraints [constraint] = constraint+      formatConstraints constraintList = constraintList+        & T.intercalate ", "+        & \cs -> "(" <> cs <> ")"++      formatConstraintsWithArrow :: [T.Text] -> T.Text+      formatConstraintsWithArrow [] = ""+      formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ")++      buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text+      buildNewConstraints constraintList redundantConstraintList =+        formatConstraintsWithArrow $ constraintList \\ redundantConstraintList++      actionTitle :: [T.Text] -> T.Text -> T.Text+      actionTitle constraintList typeSignatureName =+        "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `"+        <> formatConstraints constraintList+        <> "` from the context of the type signature for `" <> typeSignatureName <> "`"++-------------------------------------------------------------------------------------------------++suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]+suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}+  | msg <- unifySpaces _message+  , Just thingMissing <- extractNotInScopeName msg+  , qual <- extractQualifiedModuleName msg+  , Just insertLine <- case hsmodImports of+        [] -> case srcSpanStart $ getLoc (head hsmodDecls) of+          RealSrcLoc s -> Just $ srcLocLine s - 1+          _ -> Nothing+        _ -> case srcSpanEnd $ getLoc (last hsmodImports) of+          RealSrcLoc s -> Just $ srcLocLine s+          _ -> Nothing+  , insertPos <- Position insertLine 0+  , extendImportSuggestions <- matchRegexUnifySpaces msg+    "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"+  = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])+    | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions+    ]+suggestNewImport _ _ _ = []++constructNewImportSuggestions+  :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [T.Text]+constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd+  [ suggestion+  | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing]+  , (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)+  , canUseIdent thingMissing identInfo+  , m `notElem` fromMaybe [] notTheseModules+  , suggestion <- renderNewImport identInfo m+  ]+ where+  renderNewImport :: IdentInfo -> T.Text -> [T.Text]+  renderNewImport identInfo m+    | Just q <- qual+    , asQ <- if q == m then "" else " as " <> q+    = ["import qualified " <> m <> asQ]+    | otherwise+    = ["import " <> m <> " (" <> renderImportStyle importStyle <> ")"+      | importStyle <- NE.toList $ importStyles identInfo] +++      ["import " <> m ]++canUseIdent :: NotInScope -> IdentInfo -> Bool+canUseIdent NotInScopeDataConstructor{} = isDatacon+canUseIdent _                           = const True++data NotInScope+    = NotInScopeDataConstructor T.Text+    | NotInScopeTypeConstructorOrClass T.Text+    | NotInScopeThing T.Text+    deriving Show++notInScope :: NotInScope -> T.Text+notInScope (NotInScopeDataConstructor t) = t+notInScope (NotInScopeTypeConstructorOrClass t) = t+notInScope (NotInScopeThing t) = t++extractNotInScopeName :: T.Text -> Maybe NotInScope+extractNotInScopeName x+  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"+  = Just $ NotInScopeDataConstructor name+  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"+  = Just $ NotInScopeDataConstructor name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"+  = Just $ NotInScopeTypeConstructorOrClass name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"+  = Just $ NotInScopeThing name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"+  = Just $ NotInScopeThing name+  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"+  = Just $ NotInScopeThing name+  | otherwise+  = Nothing++extractQualifiedModuleName :: T.Text -> Maybe T.Text+extractQualifiedModuleName x+  | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"+  = Just m+  | otherwise+  = Nothing++-------------------------------------------------------------------------------------------------+++mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit+mkRenameEdit contents range name =+    if maybeIsInfixFunction == Just True+      then TextEdit range ("`" <> name <> "`")+      else TextEdit range name+  where+    maybeIsInfixFunction = do+      curr <- textInRange range <$> contents+      pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr++extractWildCardTypeSignature :: T.Text -> T.Text+extractWildCardTypeSignature =+  -- inferring when parens are actually needed around the type signature would+  -- require understanding both the precedence of the context of the _ and of+  -- the signature itself. Inserting them unconditionally is ugly but safe.+  ("(" `T.append`) . (`T.append` ")") .+  T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .+  snd . T.breakOnEnd "standing for "++extractRenamableTerms :: T.Text -> [T.Text]+extractRenamableTerms msg+  -- Account for both "Variable not in scope" and "Not in scope"+  | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg+  | otherwise = []+  where+    extractSuggestions = map getEnclosed+                       . concatMap singleSuggestions+                       . filter isKnownSymbol+                       . T.lines+    singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited+    isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t+    getEnclosed = T.dropWhile (== '‘')+                . T.dropWhileEnd (== '’')+                . T.dropAround (\c -> c /= '‘' && c /= '’')++-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace+-- between the end of the range and the next newline), extend the range to take up the whole line.+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range+extendToWholeLineIfPossible contents range@Range{..} =+    let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents+        extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line+    in if extend then Range _start (Position (_line _end + 1) 0) else range++splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)+splitTextAtPosition (Position row col) x+    | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x+    , (preCol, postCol) <- T.splitAt col mid+        = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)+    | otherwise = (x, T.empty)++-- | Returns [start .. end[+textInRange :: Range -> T.Text -> T.Text+textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =+    case compare startRow endRow of+      LT ->+        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine+            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of+              [] -> ("", [])+              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)+            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines+        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)+      EQ ->+        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)+        in T.take (endCol - startCol) (T.drop startCol line)+      GT -> ""+    where+      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)++-- | Returns the ranges for a binding in an import declaration+rangesForBinding :: ImportDecl GhcPs -> String -> [Range]+rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =+    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies+  where+    b' = wrapOperatorInParens (unqualify b)++    wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"++    unqualify x = snd $ breakOnEnd "." x++rangesForBinding _ _ = []++rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]+rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l]+rangesForBinding' b (L l (IEThingWith _ thing _  inners labels))+    | showSDocUnsafe (ppr thing) == b = [l]+    | otherwise =+        [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] +++        [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]+rangesForBinding' _ _ = []++-- | Extends an import list with a new binding.+--   Assumes an import statement of the form:+--       import (qualified) A (..) ..+--   Places the new binding first, preserving whitespace.+--   Copes with multi-line import lists+addBindingToImportList :: ImportStyle -> T.Text -> Maybe T.Text+addBindingToImportList importStyle importLine =+  case T.breakOn "(" importLine of+    (pre, T.uncons -> Just (_, rest)) ->+      case importStyle of+        ImportTopLevel rendered ->+          -- the binding has no parent, add it to the head of import list+          Just $ T.concat [pre, "(", rendered, addCommaIfNeeds rest]+        ImportViaParent rendered parent -> case T.breakOn parent rest of+          -- the binding has a parent, and the current import list contains the+          -- parent+          --+          -- `rest'` could be 1. `,...)`+          --               or 2. `(),...)`+          --               or 3. `(ConsA),...)`+          --               or 4. `)`+          (leading, T.stripPrefix parent -> Just rest') -> case T.uncons (T.stripStart rest') of+            -- case 1: no children and parentheses, e.g. `import A(Foo,...)` --> `import A(Foo(Cons), ...)`+            Just (',', rest'') -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", addCommaIfNeeds rest'']+            -- case 2: no children but parentheses, e.g. `import A(Foo(),...)` --> `import A(Foo(Cons), ...)`+            Just ('(', T.uncons -> Just (')', rest'')) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest'']+            -- case 3: children with parentheses, e.g. `import A(Foo(ConsA),...)` --> `import A(Foo(Cons, ConsA), ...)`+            Just ('(', T.breakOn ")" -> (children, rest''))+              | not (T.null children),+                -- ignore A(Foo({-...-}), ...)+                not $ "{-" `T.isPrefixOf` T.stripStart children+              -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ", ", children, rest'']+            -- case 4: no trailing, e.g. `import A(..., Foo)` --> `import A(..., Foo(Cons))`+            Just (')', _) -> Just $ T.concat [pre, "(", leading, parent, "(", rendered, ")", rest']+            _ -> Nothing+          -- current import list does not contain the parent, e.g. `import A(...)` --> `import A(Foo(Cons), ...)`+          _ -> Just $ T.concat [pre, "(", parent, "(", rendered, ")", addCommaIfNeeds rest]+    _ -> Nothing+  where+    addCommaIfNeeds r = case T.uncons (T.stripStart r) of+      Just (')', _) -> r+      _ -> ", " <> r++-- | 'matchRegex' combined with 'unifySpaces'+matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]+matchRegexUnifySpaces message = matchRegex (unifySpaces message)++-- | Returns Just (the submatches) for the first capture, or Nothing.+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]+matchRegex message regex = case message =~~ regex of+    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings+    Nothing -> Nothing++setHandlersCodeLens :: PartialHandlers c+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.codeLensHandler =+        withResponse RspCodeLens codeLens,+    LSP.executeCommandHandler =+        withResponseAndRequest+            RspExecuteCommand+            ReqApplyWorkspaceEdit+            commandHandler+    }++filterNewlines :: T.Text -> T.Text+filterNewlines = T.concat  . T.lines++unifySpaces :: T.Text -> T.Text+unifySpaces    = T.unwords . T.words++-- functions to help parse multiple import suggestions++-- | Returns the first match if found+regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text+regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of+    Just (h:_) -> Just h+    _ -> Nothing++-- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and+-- | return (Data.Map, app/ModuleB.hs:2:1-18)+regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)+regExPair (modname, srcpair) = do+  x <- regexSingleMatch modname "‘([^’]*)’"+  y <- regexSingleMatch srcpair "\\((.*)\\)"+  return (x, y)++-- | Process a list of (module_name, filename:src_span) values+-- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]+regExImports :: T.Text -> Maybe [(T.Text, T.Text)]+regExImports msg = result+  where+    parts = T.words msg+    isPrefix = not . T.isPrefixOf "("+    (mod, srcspan) = partition isPrefix  parts+    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))+    result = if length mod == length srcspan then+               regExPair `traverse` zip mod srcspan+             else Nothing++matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])+matchRegExMultipleImports message = do+  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"+  (binding, imports) <- case matchRegexUnifySpaces message pat of+                            Just [x, xs] -> Just (x, xs)+                            _ -> Nothing+  imps <- regExImports imports+  return (binding, imps)++-- | Possible import styles for an 'IdentInfo'.+--+-- The first 'Text' parameter corresponds to the 'rendered' field of the+-- 'IdentInfo'.+data ImportStyle+    = ImportTopLevel T.Text+      -- ^ Import a top-level export from a module, e.g., a function, a type, a+      -- class.+      --+      -- > import M (?)+      --+      -- Some exports that have a parent, like a type-class method or an+      -- associated type/data family, can still be imported as a top-level+      -- import.+      --+      -- Note that this is not the case for constructors, they must always be+      -- imported as part of their parent data type.++    | ImportViaParent T.Text T.Text+      -- ^ Import an export (first parameter) through its parent (second+      -- parameter).+      --+      -- import M (P(?))+      --+      -- @P@ and @?@ can be a data type and a constructor, a class and a method,+      -- a class and an associated type/data family, etc.++importStyles :: IdentInfo -> NonEmpty ImportStyle+importStyles IdentInfo {parent, rendered, isDatacon}+  | Just p <- parent+    -- Constructors always have to be imported via their parent data type, but+    -- methods and associated type/data families can also be imported as+    -- top-level exports.+  = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon]+  | otherwise+  = ImportTopLevel rendered :| []++renderImportStyle :: ImportStyle -> T.Text+renderImportStyle (ImportTopLevel x) = x+renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"
src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs view
@@ -1,131 +1,131 @@--- | Position indexed streams of characters
-module Development.IDE.Plugin.CodeAction.PositionIndexed
-  ( PositionIndexed
-  , PositionIndexedString
-  , indexedByPosition
-  , indexedByPositionStartingFrom
-  , extendAllToIncludeCommaIfPossible
-  , extendToIncludePreviousNewlineIfPossible
-  , mergeRanges
-  )
-where
-
-import           Data.Char
-import           Data.List
-import           Language.Haskell.LSP.Types
-
-type PositionIndexed a = [(Position, a)]
-
-type PositionIndexedString = PositionIndexed Char
-
--- | Add position indexing to a String.
---
---   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡
---   >   [ ((0,0),'h')
---   >   , ((0,1),'e')
---   >   , ((0,2),'y')
---   >   , ((0,3),'\n')
---   >   , ((1,0),' ')
---   >   , ((1,1),'h')
---   >   , ((1,2),'o')
---   >   ]
-indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString
-indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where
-  f (_, []) = Nothing
-  f (p@(Position l _), '\n' : rest) =
-    Just ((p, '\n'), (Position (l + 1) 0, rest))
-  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))
-
--- | Add position indexing to a String.
---
---   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
-indexedByPosition :: String -> PositionIndexedString
-indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
-
--- | Returns a tuple (before, contents, after) if the range is present.
---   The range is present only if both its start and end positions are present
-unconsRange
-  :: Range
-  -> PositionIndexed a
-  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)
-unconsRange Range {..} indexedString
-  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString
-  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest
-  = Just (before, mid, after)
-  | otherwise
-  = Nothing
-
--- | Strips out all the positions included in the range.
---   Returns 'Nothing' if the start or end of the range are not included in the input.
-stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)
-stripRange r s = case unconsRange r s of
-  Just (b, _, a) -> Just (b ++ a)
-  Nothing        -> Nothing
-
--- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.
---   Assumes input ranges are sorted on the start positions.
-mergeRanges :: [Range] -> [Range]
-mergeRanges (r : r' : rest)
-  |
-    -- r' is contained in r
-    _end r > _end r'   = mergeRanges (r : rest)
-  |
-    -- r and r' are overlapping
-    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)
-
-  | otherwise          = r : mergeRanges (r' : rest)
-mergeRanges other = other
-
--- | Returns a sorted list of ranges with extended selections including preceding or trailing commas
---
--- @
---   a, |b|,  c  ===> a|, b|,  c
---   a,  b,  |c| ===> a,  b|,  c|
---   a, |b|, |c| ===> a|, b||, c|
--- @
-extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
-extendAllToIncludeCommaIfPossible indexedString =
-  mergeRanges . go indexedString . sortOn _start
- where
-  go _ [] = []
-  go input (r : rr)
-    | r' : _ <- extendToIncludeCommaIfPossible input r
-    , Just input' <- stripRange r' input
-    = r' : go input' rr
-    | otherwise
-    = go input rr
-
-extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
-extendToIncludeCommaIfPossible indexedString range
-  | Just (before, _, after) <- unconsRange range indexedString
-  , after' <- dropWhile (isSpace . snd) after
-  , before' <- dropWhile (isSpace . snd) (reverse before)
-  =
-    -- a, |b|, c ===> a|, b|, c
-    [ range { _start = start' } | (start', ',') : _ <- [before'] ]
-    ++
-    -- a, |b|, c ===> a, |b, |c
-    [ range { _end = end' }
-    | (_, ',') : rest <- [after']
-    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest
-    ]
-  | otherwise
-  = [range]
-
-extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range
-extendToIncludePreviousNewlineIfPossible indexedString range
-  | Just (before, _, _) <- unconsRange range indexedString
-  , maybeFirstSpacePos <- lastSpacePos $ reverse before
-  = case maybeFirstSpacePos of
-      Nothing -> range
-      Just pos -> range { _start = pos }
-  | otherwise = range
-  where
-    lastSpacePos :: PositionIndexedString -> Maybe Position
-    lastSpacePos [] = Nothing
-    lastSpacePos ((pos, c):xs) =
-      if not $ isSpace c
-      then Nothing -- didn't find any space
-      else case xs of
-              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)
+-- | Position indexed streams of characters+module Development.IDE.Plugin.CodeAction.PositionIndexed+  ( PositionIndexed+  , PositionIndexedString+  , indexedByPosition+  , indexedByPositionStartingFrom+  , extendAllToIncludeCommaIfPossible+  , extendToIncludePreviousNewlineIfPossible+  , mergeRanges+  )+where++import           Data.Char+import           Data.List+import           Language.Haskell.LSP.Types++type PositionIndexed a = [(Position, a)]++type PositionIndexedString = PositionIndexed Char++-- | Add position indexing to a String.+--+--   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡+--   >   [ ((0,0),'h')+--   >   , ((0,1),'e')+--   >   , ((0,2),'y')+--   >   , ((0,3),'\n')+--   >   , ((1,0),' ')+--   >   , ((1,1),'h')+--   >   , ((1,2),'o')+--   >   ]+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where+  f (_, []) = Nothing+  f (p@(Position l _), '\n' : rest) =+    Just ((p, '\n'), (Position (l + 1) 0, rest))+  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))++-- | Add position indexing to a String.+--+--   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)+indexedByPosition :: String -> PositionIndexedString+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)++-- | Returns a tuple (before, contents, after) if the range is present.+--   The range is present only if both its start and end positions are present+unconsRange+  :: Range+  -> PositionIndexed a+  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)+unconsRange Range {..} indexedString+  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString+  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest+  = Just (before, mid, after)+  | otherwise+  = Nothing++-- | Strips out all the positions included in the range.+--   Returns 'Nothing' if the start or end of the range are not included in the input.+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)+stripRange r s = case unconsRange r s of+  Just (b, _, a) -> Just (b ++ a)+  Nothing        -> Nothing++-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.+--   Assumes input ranges are sorted on the start positions.+mergeRanges :: [Range] -> [Range]+mergeRanges (r : r' : rest)+  |+    -- r' is contained in r+    _end r > _end r'   = mergeRanges (r : rest)+  |+    -- r and r' are overlapping+    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)++  | otherwise          = r : mergeRanges (r' : rest)+mergeRanges other = other++-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas+--+-- @+--   a, |b|,  c  ===> a|, b|,  c+--   a,  b,  |c| ===> a,  b|,  c|+--   a, |b|, |c| ===> a|, b||, c|+-- @+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]+extendAllToIncludeCommaIfPossible indexedString =+  mergeRanges . go indexedString . sortOn _start+ where+  go _ [] = []+  go input (r : rr)+    | r' : _ <- extendToIncludeCommaIfPossible input r+    , Just input' <- stripRange r' input+    = r' : go input' rr+    | otherwise+    = go input rr++extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]+extendToIncludeCommaIfPossible indexedString range+  | Just (before, _, after) <- unconsRange range indexedString+  , after' <- dropWhile (isSpace . snd) after+  , before' <- dropWhile (isSpace . snd) (reverse before)+  =+    -- a, |b|, c ===> a|, b|, c+    [ range { _start = start' } | (start', ',') : _ <- [before'] ]+    +++    -- a, |b|, c ===> a, |b, |c+    [ range { _end = end' }+    | (_, ',') : rest <- [after']+    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest+    ]+  | otherwise+  = [range]++extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range+extendToIncludePreviousNewlineIfPossible indexedString range+  | Just (before, _, _) <- unconsRange range indexedString+  , maybeFirstSpacePos <- lastSpacePos $ reverse before+  = case maybeFirstSpacePos of+      Nothing -> range+      Just pos -> range { _start = pos }+  | otherwise = range+  where+    lastSpacePos :: PositionIndexedString -> Maybe Position+    lastSpacePos [] = Nothing+    lastSpacePos ((pos, c):xs) =+      if not $ isSpace c+      then Nothing -- didn't find any space+      else case xs of+              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)               _ -> Just pos
src/Development/IDE/Plugin/CodeAction/RuleTypes.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE TypeFamilies #-}
-module Development.IDE.Plugin.CodeAction.RuleTypes
-    (PackageExports(..)
-    ,IdentInfo(..)
-    ) where
-
-import Data.Hashable (Hashable)
-import Control.DeepSeq (NFData)
-import Data.Binary (Binary)
-import Development.IDE.GHC.Util
-import Development.IDE.Types.Exports
-import Development.Shake (RuleResult)
-import Data.Typeable (Typeable)
-import GHC.Generics (Generic)
-
--- Rule type for caching Package Exports
-type instance RuleResult PackageExports = ExportsMap
-
-newtype PackageExports = PackageExports HscEnvEq
-    deriving (Eq, Show, Typeable, Generic)
-
-instance Hashable PackageExports
-instance NFData   PackageExports
-instance Binary   PackageExports
+{-# LANGUAGE TypeFamilies #-}+module Development.IDE.Plugin.CodeAction.RuleTypes+    (PackageExports(..)+    ,IdentInfo(..)+    ) where++import Data.Hashable (Hashable)+import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Development.IDE.GHC.Util+import Development.IDE.Types.Exports+import Development.Shake (RuleResult)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++-- Rule type for caching Package Exports+type instance RuleResult PackageExports = ExportsMap++newtype PackageExports = PackageExports HscEnvEq+    deriving (Eq, Show, Typeable, Generic)++instance Hashable PackageExports+instance NFData   PackageExports+instance Binary   PackageExports
src/Development/IDE/Plugin/CodeAction/Rules.hs view
@@ -1,45 +1,45 @@-module Development.IDE.Plugin.CodeAction.Rules
-  ( rulePackageExports
-  )
-where
-
-import           Data.Traversable               ( forM )
-import           Development.IDE.Core.Rules
-import           Development.IDE.GHC.Util
-import           Development.IDE.Plugin.CodeAction.RuleTypes
-import           Development.IDE.Types.Exports
-import           Development.Shake
-import           GHC                            ( DynFlags(pkgState) )
-import           HscTypes                       ( hsc_dflags)
-import           LoadIface
-import           Maybes
-import           Module                         ( Module(..) )
-import           Packages                       ( explicitPackages
-                                                , exposedModules
-                                                , packageConfigId
-                                                )
-import           TcRnMonad                      ( WhereFrom(ImportByUser)
-                                                , initIfaceLoad
-                                                )
-
-rulePackageExports :: Rules ()
-rulePackageExports = defineNoFile $ \(PackageExports session) -> do
-  let env     = hscEnv session
-      pkgst   = pkgState (hsc_dflags env)
-      depends = explicitPackages pkgst
-      targets =
-        [ (pkg, mn)
-        | d        <- depends
-        , Just pkg <- [lookupPackageConfig d env]
-        , (mn, _)  <- exposedModules pkg
-        ]
-
-  modIfaces <- forM targets $ \(pkg, mn) -> do
-    modIface <- liftIO $ initIfaceLoad env $ loadInterface
-      ""
-      (Module (packageConfigId pkg) mn)
-      (ImportByUser False)
-    return $ case modIface of
-      Failed    _err -> Nothing
-      Succeeded mi   -> Just mi
-  return $ createExportsMap (catMaybes modIfaces)
+module Development.IDE.Plugin.CodeAction.Rules+  ( rulePackageExports+  )+where++import           Data.Traversable               ( forM )+import           Development.IDE.Core.Rules+import           Development.IDE.GHC.Util+import           Development.IDE.Plugin.CodeAction.RuleTypes+import           Development.IDE.Types.Exports+import           Development.Shake+import           GHC                            ( DynFlags(pkgState) )+import           HscTypes                       ( hsc_dflags)+import           LoadIface+import           Maybes+import           Module                         ( Module(..) )+import           Packages                       ( explicitPackages+                                                , exposedModules+                                                , packageConfigId+                                                )+import           TcRnMonad                      ( WhereFrom(ImportByUser)+                                                , initIfaceLoad+                                                )++rulePackageExports :: Rules ()+rulePackageExports = defineNoFile $ \(PackageExports session) -> do+  let env     = hscEnv session+      pkgst   = pkgState (hsc_dflags env)+      depends = explicitPackages pkgst+      targets =+        [ (pkg, mn)+        | d        <- depends+        , Just pkg <- [lookupPackageConfig d env]+        , (mn, _)  <- exposedModules pkg+        ]++  modIfaces <- forM targets $ \(pkg, mn) -> do+    modIface <- liftIO $ initIfaceLoad env $ loadInterface+      ""+      (Module (packageConfigId pkg) mn)+      (ImportByUser False)+    return $ case modIface of+      Failed    _err -> Nothing+      Succeeded mi   -> Just mi+  return $ createExportsMap (catMaybes modIfaces)
src/Development/IDE/Plugin/Completions.hs view
@@ -1,153 +1,156 @@-{-# LANGUAGE CPP          #-}
-{-# LANGUAGE TypeFamilies #-}
-#include "ghc-api-version.h"
-
-module Development.IDE.Plugin.Completions
-    (
-      plugin
-    , getCompletionsLSP
-    ) where
-
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Core as LSP
-import qualified Language.Haskell.LSP.VFS as VFS
-
-import Development.Shake.Classes
-import Development.Shake
-import GHC.Generics
-
-import Development.IDE.Plugin
-import Development.IDE.Core.Service
-import Development.IDE.Core.PositionMapping
-import Development.IDE.Plugin.Completions.Logic
-import Development.IDE.Types.Location
-import Development.IDE.Core.RuleTypes
-import Development.IDE.Core.Shake
-import Development.IDE.GHC.Compat
-
-import Development.IDE.GHC.Util
-import Development.IDE.LSP.Server
-import TcRnDriver (tcRnImportDecls)
-import Data.Maybe
-
-#if defined(GHC_LIB)
-import Development.IDE.Import.DependencyInformation
-#endif
-
-plugin :: Plugin c
-plugin = Plugin produceCompletions setHandlersCompletion
-
-produceCompletions :: Rules ()
-produceCompletions = do
-    define $ \ProduceCompletions file -> do
-        local <- useWithStale LocalCompletions file
-        nonLocal <- useWithStale NonLocalCompletions file
-        let extract = fmap fst
-        return ([], extract local <> extract nonLocal)
-    define $ \LocalCompletions file -> do
-        pm <- useWithStale GetParsedModule file
-        case pm of
-            Just (pm, _) -> do
-                let cdata = localCompletionsForParsedModule pm
-                return ([], Just cdata)
-            _ -> return ([], Nothing)
-    define $ \NonLocalCompletions file -> do
-        -- For non local completions we avoid depending on the parsed module,
-        -- synthetizing a fake module with an empty body from the buffer
-        -- in the ModSummary, which preserves all the imports
-        ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file
-        sess <- fmap fst <$> useWithStale GhcSessionDeps file
-
--- When possible, rely on the haddocks embedded in our interface files
--- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
-#if !defined(GHC_LIB)
-        let parsedDeps = []
-#else
-        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
-        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
-#endif
-
-        case (ms, sess) of
-            (Just (ms,imps), Just sess) -> do
-              let env = hscEnv sess
-              -- We do this to be able to provide completions of items that are not restricted to the explicit list
-              res <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps)
-              case res of
-                  (_, Just rdrEnv) -> do
-                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps
-                      return ([], Just cdata)
-                  (_diag, _) ->
-                      return ([], Nothing)
-            _ -> return ([], Nothing)
-
--- Drop any explicit imports in ImportDecl if not hidden
-dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs)
-dropListFromImportDecl iDecl = let
-    f d@ImportDecl {ideclHiding} = case ideclHiding of
-        Just (False, _) -> d {ideclHiding=Nothing}
-        -- if hiding or Nothing just return d
-        _ -> d
-    f x = x
-    in f <$> iDecl
-
--- | Produce completions info for a file
-type instance RuleResult ProduceCompletions = CachedCompletions
-type instance RuleResult LocalCompletions = CachedCompletions
-type instance RuleResult NonLocalCompletions = CachedCompletions
-
-data ProduceCompletions = ProduceCompletions
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable ProduceCompletions
-instance NFData   ProduceCompletions
-instance Binary   ProduceCompletions
-
-data LocalCompletions = LocalCompletions
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable LocalCompletions
-instance NFData   LocalCompletions
-instance Binary   LocalCompletions
-
-data NonLocalCompletions = NonLocalCompletions
-    deriving (Eq, Show, Typeable, Generic)
-instance Hashable NonLocalCompletions
-instance NFData   NonLocalCompletions
-instance Binary   NonLocalCompletions
-
--- | Generate code actions.
-getCompletionsLSP
-    :: LSP.LspFuncs cofd
-    -> IdeState
-    -> CompletionParams
-    -> IO (Either ResponseError CompletionResponseResult)
-getCompletionsLSP lsp ide
-  CompletionParams{_textDocument=TextDocumentIdentifier uri
-                  ,_position=position
-                  ,_context=completionContext} = do
-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
-    fmap Right $ case (contents, uriToFilePath' uri) of
-      (Just cnts, Just path) -> do
-        let npath = toNormalizedFilePath' path
-        (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do
-            opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
-            compls <- useWithStaleFast ProduceCompletions npath
-            pm <- useWithStaleFast GetParsedModule npath
-            binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath
-            pure (opts, fmap (,pm,binds) compls )
-        case compls of
-          Just ((cci', _), parsedMod, bindMap) -> do
-            pfix <- VFS.getCompletionPrefix position cnts
-            case (pfix, completionContext) of
-              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
-                -> return (Completions $ List [])
-              (Just pfix', _) -> do
-                let clientCaps = clientCapabilities $ shakeExtras ide
-                Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True)
-              _ -> return (Completions $ List [])
-          _ -> return (Completions $ List [])
-      _ -> return (Completions $ List [])
-
-setHandlersCompletion :: PartialHandlers c
-setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
-    }
+{-# LANGUAGE CPP          #-}+{-# LANGUAGE TypeFamilies #-}+#include "ghc-api-version.h"++module Development.IDE.Plugin.Completions+    (+      plugin+    , getCompletionsLSP+    ) where++import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Core as LSP+import qualified Language.Haskell.LSP.VFS as VFS++import Development.Shake.Classes+import Development.Shake+import GHC.Generics++import Development.IDE.Plugin+import Development.IDE.Core.Service+import Development.IDE.Core.PositionMapping+import Development.IDE.Plugin.Completions.Logic+import Development.IDE.Types.Location+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Shake+import Development.IDE.GHC.Compat++import Development.IDE.GHC.Util+import Development.IDE.LSP.Server+import TcRnDriver (tcRnImportDecls)+import Data.Maybe+import Ide.Plugin.Config (Config(completionSnippetsOn))+import Ide.PluginUtils (getClientConfig)++#if defined(GHC_LIB)+import Development.IDE.Import.DependencyInformation+#endif++plugin :: Plugin Config+plugin = Plugin produceCompletions setHandlersCompletion++produceCompletions :: Rules ()+produceCompletions = do+    define $ \ProduceCompletions file -> do+        local <- useWithStale LocalCompletions file+        nonLocal <- useWithStale NonLocalCompletions file+        let extract = fmap fst+        return ([], extract local <> extract nonLocal)+    define $ \LocalCompletions file -> do+        pm <- useWithStale GetParsedModule file+        case pm of+            Just (pm, _) -> do+                let cdata = localCompletionsForParsedModule pm+                return ([], Just cdata)+            _ -> return ([], Nothing)+    define $ \NonLocalCompletions file -> do+        -- For non local completions we avoid depending on the parsed module,+        -- synthetizing a fake module with an empty body from the buffer+        -- in the ModSummary, which preserves all the imports+        ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file+        sess <- fmap fst <$> useWithStale GhcSessionDeps file++-- When possible, rely on the haddocks embedded in our interface files+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'+#if !defined(GHC_LIB)+        let parsedDeps = []+#else+        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file+        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)+#endif++        case (ms, sess) of+            (Just (ms,imps), Just sess) -> do+              let env = hscEnv sess+              -- We do this to be able to provide completions of items that are not restricted to the explicit list+              res <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> imps)+              case res of+                  (_, Just rdrEnv) -> do+                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps+                      return ([], Just cdata)+                  (_diag, _) ->+                      return ([], Nothing)+            _ -> return ([], Nothing)++-- Drop any explicit imports in ImportDecl if not hidden+dropListFromImportDecl :: GenLocated SrcSpan (ImportDecl GhcPs) -> GenLocated SrcSpan (ImportDecl GhcPs)+dropListFromImportDecl iDecl = let+    f d@ImportDecl {ideclHiding} = case ideclHiding of+        Just (False, _) -> d {ideclHiding=Nothing}+        -- if hiding or Nothing just return d+        _ -> d+    f x = x+    in f <$> iDecl++-- | Produce completions info for a file+type instance RuleResult ProduceCompletions = CachedCompletions+type instance RuleResult LocalCompletions = CachedCompletions+type instance RuleResult NonLocalCompletions = CachedCompletions++data ProduceCompletions = ProduceCompletions+    deriving (Eq, Show, Typeable, Generic)+instance Hashable ProduceCompletions+instance NFData   ProduceCompletions+instance Binary   ProduceCompletions++data LocalCompletions = LocalCompletions+    deriving (Eq, Show, Typeable, Generic)+instance Hashable LocalCompletions+instance NFData   LocalCompletions+instance Binary   LocalCompletions++data NonLocalCompletions = NonLocalCompletions+    deriving (Eq, Show, Typeable, Generic)+instance Hashable NonLocalCompletions+instance NFData   NonLocalCompletions+instance Binary   NonLocalCompletions++-- | Generate code actions.+getCompletionsLSP+    :: LSP.LspFuncs Config+    -> IdeState+    -> CompletionParams+    -> IO (Either ResponseError CompletionResponseResult)+getCompletionsLSP lsp ide+  CompletionParams{_textDocument=TextDocumentIdentifier uri+                  ,_position=position+                  ,_context=completionContext} = do+    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    fmap Right $ case (contents, uriToFilePath' uri) of+      (Just cnts, Just path) -> do+        let npath = toNormalizedFilePath' path+        (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do+            opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide+            compls <- useWithStaleFast ProduceCompletions npath+            pm <- useWithStaleFast GetParsedModule npath+            binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath+            pure (opts, fmap (,pm,binds) compls )+        case compls of+          Just ((cci', _), parsedMod, bindMap) -> do+            pfix <- VFS.getCompletionPrefix position cnts+            case (pfix, completionContext) of+              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})+                -> return (Completions $ List [])+              (Just pfix', _) -> do+                let clientCaps = clientCapabilities $ shakeExtras ide+                snippets <- WithSnippets . completionSnippetsOn <$> getClientConfig lsp+                Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps snippets+              _ -> return (Completions $ List [])+          _ -> return (Completions $ List [])+      _ -> return (Completions $ List [])++setHandlersCompletion :: PartialHandlers Config+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP+    }
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -1,726 +1,726 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE GADTs#-}
-
-#include "ghc-api-version.h"
-
--- Mostly taken from "haskell-ide-engine"
-module Development.IDE.Plugin.Completions.Logic (
-  CachedCompletions
-, cacheDataProducer
-, localCompletionsForParsedModule
-, WithSnippets(..)
-, getCompletions
-) where
-
-import Control.Applicative
-import Data.Char (isAlphaNum, isUpper)
-import Data.Generics
-import Data.List.Extra as List hiding (stripPrefix)
-import qualified Data.Map  as Map
-
-import Data.Maybe (listToMaybe, fromMaybe, mapMaybe)
-import qualified Data.Text as T
-import qualified Text.Fuzzy as Fuzzy
-
-import HscTypes
-import Name
-import RdrName
-import Type
-import Packages
-#if MIN_GHC_API_VERSION(8,10,0)
-import Predicate (isDictTy)
-import Pair
-import Coercion
-#endif
-
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Capabilities
-import qualified Language.Haskell.LSP.VFS as VFS
-import Development.IDE.Core.Compile
-import Development.IDE.Core.PositionMapping
-import Development.IDE.Plugin.Completions.Types
-import Development.IDE.Spans.Documentation
-import Development.IDE.Spans.LocalBindings
-import Development.IDE.GHC.Compat as GHC
-import Development.IDE.GHC.Error
-import Development.IDE.Types.Options
-import Development.IDE.Spans.Common
-import Development.IDE.GHC.Util
-import Outputable (Outputable)
-import qualified Data.Set as Set
-import ConLike
-
-import GhcPlugins (
-    flLabel,
-    unpackFS)
-import Data.Either (fromRight)
-
--- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
-
--- | A context of a declaration in the program
--- e.g. is the declaration a type declaration or a value declaration
--- Used for determining which code completions to show
--- TODO: expand this with more contexts like classes or instances for
--- smarter code completion
-data Context = TypeContext
-             | ValueContext
-             | ModuleContext String -- ^ module context with module name
-             | ImportContext String -- ^ import context with module name
-             | ImportListContext String -- ^ import list context with module name
-             | ImportHidingContext String -- ^ import hiding context with module name
-             | ExportContext -- ^ List of exported identifiers from the current module
-  deriving (Show, Eq)
-
--- | Generates a map of where the context is a type and where the context is a value
--- i.e. where are the value decls and the type decls
-getCContext :: Position -> ParsedModule -> Maybe Context
-getCContext pos pm
-  | Just (L r modName) <- moduleHeader
-  , pos `isInsideSrcSpan` r
-  = Just (ModuleContext (moduleNameString modName))
-
-  | Just (L r _) <- exportList
-  , pos `isInsideSrcSpan` r
-  = Just ExportContext
-
-  | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
-  = Just ctx
-
-  | Just ctx <- something (Nothing `mkQ` importGo) imports
-  = Just ctx
-
-  | otherwise
-  = Nothing
-
-  where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
-        moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
-        exportList = hsmodExports $ unLoc $ pm_parsed_source pm
-        imports = hsmodImports $ unLoc $ pm_parsed_source pm
-
-        go :: LHsDecl GhcPs -> Maybe Context
-        go (L r SigD {})
-          | pos `isInsideSrcSpan` r = Just TypeContext
-          | otherwise = Nothing
-        go (L r GHC.ValD {})
-          | pos `isInsideSrcSpan` r = Just ValueContext
-          | otherwise = Nothing
-        go _ = Nothing
-
-        goInline :: GHC.LHsType GhcPs -> Maybe Context
-        goInline (GHC.L r _)
-          | pos `isInsideSrcSpan` r = Just TypeContext
-        goInline _ = Nothing
-
-        importGo :: GHC.LImportDecl GhcPs -> Maybe Context
-        importGo (L r impDecl)
-          | pos `isInsideSrcSpan` r
-          = importInline importModuleName (ideclHiding impDecl)
-          <|> Just (ImportContext importModuleName)
-
-          | otherwise = Nothing
-          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
-
-        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context
-        importInline modName (Just (True, L r _))
-          | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName
-          | otherwise = Nothing
-        importInline modName (Just (False, L r _))
-          | pos `isInsideSrcSpan` r = Just $ ImportListContext modName
-          | otherwise = Nothing
-        importInline _ _ = Nothing
-
-occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind
-occNameToComKind ty oc
-  | isVarOcc  oc = case occNameString oc of
-                     i:_ | isUpper i -> CiConstructor
-                     _               -> CiFunction
-  | isTcOcc   oc = case ty of
-                     Just t
-                       | "Constraint" `T.isSuffixOf` t
-                       -> CiClass
-                     _ -> CiStruct
-  | isDataOcc oc = CiConstructor
-  | otherwise    = CiVariable
-
-
-showModName :: ModuleName -> T.Text
-showModName = T.pack . moduleNameString
-
--- mkCompl :: IdeOptions -> CompItem -> CompletionItem
--- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =
---   CompletionItem label kind (List []) ((colon <>) <$> typeText)
---     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
---     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
---     Nothing Nothing Nothing Nothing Nothing
-
-mkCompl :: IdeOptions -> CompItem -> CompletionItem
-mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} =
-  CompletionItem {_label = label,
-                  _kind = kind,
-                  _tags = List [],
-                  _detail = (colon <>) <$> typeText,
-                  _documentation = documentation,
-                  _deprecated = Nothing,
-                  _preselect = Nothing,
-                  _sortText = Nothing,
-                  _filterText = Nothing,
-                  _insertText = Just insertText,
-                  _insertTextFormat = Just Snippet,
-                  _textEdit = Nothing,
-                  _additionalTextEdits = List <$> additionalTextEdits,
-                  _commitCharacters = Nothing,
-                  _command = Nothing,
-                  _xdata = Nothing}
-
-  where kind = Just compKind
-        docs' = imported : spanDocToMarkdown docs
-        imported = case importedFrom of
-          Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"
-          Right mod -> "*Defined in '" <> mod <> "'*\n"
-        colon = if optNewColonConvention then ": " else ":: "
-        documentation = Just $ CompletionDocMarkup $
-                        MarkupContent MkMarkdown $
-                        T.intercalate sectionSeparator docs'
-
-mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
-mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..}
-  where
-    compKind = occNameToComKind typeText $ occName origName
-    importedFrom = Right $ showModName origMod
-    isTypeCompl = isTcOcc $ occName origName
-    label = T.pack $ showGhc origName
-    insertText = case isInfix of
-            Nothing -> case getArgText <$> thingType of
-                            Nothing -> label
-                            Just argText -> label <> " " <> argText
-            Just LeftSide -> label <> "`"
-
-            Just Surrounded -> label
-    typeText
-          | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
-          | otherwise = Nothing
-    additionalTextEdits = imp >>= extendImportList (showGhc origName)
-
-    stripForall :: T.Text -> T.Text
-    stripForall t
-      | T.isPrefixOf "forall" t =
-        -- We drop 2 to remove the '.' and the space after it
-        T.drop 2 (T.dropWhile (/= '.') t)
-      | otherwise               = t
-
-    getArgText :: Type -> T.Text
-    getArgText typ = argText
-      where
-        argTypes = getArgs typ
-        argText :: T.Text
-        argText =  mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
-        snippet :: Int -> Type -> T.Text
-        snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
-        getArgs :: Type -> [Type]
-        getArgs t
-          | isPredTy t = []
-          | isDictTy t = []
-          | isForAllTy t = getArgs $ snd (splitForAllTys t)
-          | isFunTy t =
-            let (args, ret) = splitFunTys t
-              in if isForAllTy ret
-                  then getArgs ret
-                  else Prelude.filter (not . isDictTy) args
-          | isPiTy t = getArgs $ snd (splitPiTys t)
-#if MIN_GHC_API_VERSION(8,10,0)
-          | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t
-          = getArgs t
-#else
-          | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
-#endif
-          | otherwise = []
-
-mkModCompl :: T.Text -> CompletionItem
-mkModCompl label =
-  CompletionItem label (Just CiModule) (List []) Nothing
-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-    Nothing Nothing Nothing Nothing Nothing
-
-mkImportCompl :: T.Text -> T.Text -> CompletionItem
-mkImportCompl enteredQual label =
-  CompletionItem m (Just CiModule) (List []) (Just label)
-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-    Nothing Nothing Nothing Nothing Nothing
-  where
-    m = fromMaybe "" (T.stripPrefix enteredQual label)
-
-mkExtCompl :: T.Text -> CompletionItem
-mkExtCompl label =
-  CompletionItem label (Just CiKeyword) (List []) Nothing
-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-    Nothing Nothing Nothing Nothing Nothing
-
-mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
-mkPragmaCompl label insertText =
-  CompletionItem label (Just CiKeyword) (List []) Nothing
-    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
-    Nothing Nothing Nothing Nothing Nothing
-
-extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit]
-extendImportList name lDecl = let
-    f (Just range) ImportDecl {ideclHiding} = case ideclHiding of
-        Just (False, x)
-          | Set.notMember name (Set.fromList [show y| y <- unLoc x])
-          -> let
-            start_pos = _end range
-            new_start_pos = start_pos {_character = _character start_pos - 1}
-            -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules
-            new_range = Range new_start_pos new_start_pos
-            -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$)
-            alpha = all isAlphaNum $ filter (\c -> c /= '_') name
-            result = if alpha then name ++ ", "
-                else "(" ++ name ++ "), "
-            in Just [TextEdit new_range (T.pack result)]
-          | otherwise -> Nothing
-        _ -> Nothing  -- hiding import list and no list
-    f _ _ = Nothing
-    src_span = srcSpanToRange . getLoc $ lDecl
-    in f src_span . unLoc $ lDecl
-
-
-cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions
-cacheDataProducer packageState curMod rdrEnv limports deps = do
-  let dflags = hsc_dflags packageState
-      curModName = moduleName curMod
-
-      iDeclToModName :: ImportDecl name -> ModuleName
-      iDeclToModName = unLoc . ideclName
-
-      asNamespace :: ImportDecl name -> ModuleName
-      asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
-      -- Full canonical names of imported modules
-      importDeclerations = map unLoc limports
-
-      -- The list of all importable Modules from all packages
-      moduleNames = map showModName (listVisibleModuleNames dflags)
-
-      -- The given namespaces for the imported modules (ie. full name, or alias if used)
-      allModNamesAsNS = map (showModName . asNamespace) importDeclerations
-
-      rdrElts = globalRdrEnvElts rdrEnv
-
-      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
-      foldMapM f xs = foldr step return xs mempty where
-        step x r z = f x >>= \y -> r $! z `mappend` y
-
-      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)
-      getCompls = foldMapM getComplsForOne
-
-      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
-      getComplsForOne (GRE n _ True _) =
-          (, mempty) <$> toCompItem curMod curModName n Nothing
-      getComplsForOne (GRE n _ False prov) =
-        flip foldMapM (map is_decl prov) $ \spec -> do
-          compItem <- toCompItem curMod (is_mod spec) n Nothing
-          let unqual
-                | is_qual spec = []
-                | otherwise = compItem
-              qual
-                | is_qual spec = Map.singleton asMod compItem
-                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
-              asMod = showModName (is_as spec)
-              origMod = showModName (is_mod spec)
-          return (unqual,QualCompls qual)
-
-      toCompItem :: Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
-      toCompItem m mn n imp' = do
-        docs <- getDocumentationTryGhc packageState curMod deps n
-        ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
-                name' <- lookupName packageState m n
-                return $ name' >>= safeTyThingType
-        -- use the same pass to also capture any Record snippets that we can collect
-        record_ty <- catchSrcErrors (hsc_dflags packageState) "record-completion" $ do
-                name' <- lookupName packageState m n
-                return $ name' >>= safeTyThingForRecord
-
-        let recordCompls = case fromRight Nothing record_ty of
-                Just (ctxStr, flds) -> case flds of
-                    [] -> []
-                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp']
-                Nothing -> []
-
-        return $ mkNameCompItem n mn (fromRight Nothing ty) Nothing docs imp'
-                 : recordCompls
-
-  (unquals,quals) <- getCompls rdrElts
-
-  return $ CC
-    { allModNamesAsNS = allModNamesAsNS
-    , unqualCompls = unquals
-    , qualCompls = quals
-    , importableModules = moduleNames
-    }
-
-
--- | Produces completions from the top level declarations of a module.
-localCompletionsForParsedModule :: ParsedModule -> CachedCompletions
-localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =
-    CC { allModNamesAsNS = mempty
-       , unqualCompls = compls
-       , qualCompls = mempty
-       , importableModules = mempty
-        }
-  where
-    typeSigIds = Set.fromList
-        [ id
-            | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls
-            , L _ id <- ids
-            ]
-    hasTypeSig = (`Set.member` typeSigIds) . unLoc
-
-    compls = concat
-        [ case decl of
-            SigD _ (TypeSig _ ids typ) ->
-                [mkComp id CiFunction (Just $ ppr typ) | id <- ids]
-            ValD _ FunBind{fun_id} ->
-                [ mkComp fun_id CiFunction Nothing
-                | not (hasTypeSig fun_id)
-                ]
-            ValD _ PatBind{pat_lhs} ->
-                [mkComp id CiVariable Nothing
-                | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]
-            TyClD _ ClassDecl{tcdLName, tcdSigs} ->
-                mkComp tcdLName CiClass Nothing :
-                [ mkComp id CiFunction (Just $ ppr typ)
-                | L _ (TypeSig _ ids typ) <- tcdSigs
-                , id <- ids]
-            TyClD _ x ->
-                let generalCompls = [mkComp id cl Nothing
-                        | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
-                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
-                    -- here we only have to look at the outermost type
-                    recordCompls = findRecordCompl pm thisModName x
-                in
-                   -- the constructors and snippets will be duplicated here giving the user 2 choices.
-                   generalCompls ++ recordCompls
-            ForD _ ForeignImport{fd_name,fd_sig_ty} ->
-                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
-            ForD _ ForeignExport{fd_name,fd_sig_ty} ->
-                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
-            _ -> []
-            | L _ decl <- hsmodDecls
-        ]
-
-    mkComp n ctyp ty =
-        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing
-      where
-        pn = ppr n
-        doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
-
-    thisModName = ppr hsmodName
-
-findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
-findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result
-    where
-        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing
-                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn
-                 , Just  con_details <- [getFlds con_args]
-                 , let field_names = mapMaybe extract con_details
-                 , let field_labels = T.pack . showGhc . unLoc <$> field_names
-                 , (not . List.null) field_labels
-                 ]
-        doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)
-
-        getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]
-        getFlds conArg = case conArg of
-                             RecCon rec -> Just $ unLoc <$> unLoc rec
-                             PrefixCon _ -> Just []
-                             _ -> Nothing
-
-        extract ConDeclField{..}
-             -- TODO: Why is cd_fld_names a list?
-            | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name
-            | otherwise = Nothing
-        -- XConDeclField
-        extract _ = Nothing
-findRecordCompl _ _ _ = []
-
-ppr :: Outputable a => a -> T.Text
-ppr = T.pack . prettyPrint
-
-newtype WithSnippets = WithSnippets Bool
-
-toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
-toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
-  | with && supported = x
-  | otherwise = x { _insertTextFormat = Just PlainText
-                  , _insertText       = Nothing
-                  }
-  where
-    supported =
-      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
-
--- | Returns the cached completions for the given module and position.
-getCompletions
-    :: IdeOptions
-    -> CachedCompletions
-    -> Maybe (ParsedModule, PositionMapping)
-    -> (Bindings, PositionMapping)
-    -> VFS.PosPrefixInfo
-    -> ClientCapabilities
-    -> WithSnippets
-    -> IO [CompletionItem]
-getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules}
-               maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do
-  let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
-      enteredQual = if T.null prefixModule then "" else prefixModule <> "."
-      fullPrefix  = enteredQual <> prefixText
-
-      {- correct the position by moving 'foo :: Int -> String ->    '
-                                                                    ^
-          to                             'foo :: Int -> String ->    '
-                                                              ^
-      -}
-      pos = VFS.cursorPos prefixInfo
-
-      filtModNameCompls =
-        map mkModCompl
-          $ mapMaybe (T.stripPrefix enteredQual)
-          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
-
-      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
-        where
-
-          mcc = case maybe_parsed of
-            Nothing -> Nothing
-            Just (pm, pmapping) ->
-              let PositionMapping pDelta = pmapping
-                  position' = fromDelta pDelta pos
-                  lpos = lowerRange position'
-                  hpos = upperRange position'
-              in getCContext lpos pm <|> getCContext hpos pm
-
-          -- completions specific to the current context
-          ctxCompls' = case mcc of
-                        Nothing -> compls
-                        Just TypeContext -> filter isTypeCompl compls
-                        Just ValueContext -> filter (not . isTypeCompl) compls
-                        Just _ -> filter (not . isTypeCompl) compls
-          -- Add whether the text to insert has backticks
-          ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
-
-          infixCompls :: Maybe Backtick
-          infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
-
-          PositionMapping bDelta = bmapping
-          oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
-          startLoc = lowerRange oldPos
-          endLoc = upperRange oldPos
-          localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
-          localBindsToCompItem :: Name -> Maybe Type -> CompItem
-          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing
-            where
-              occ = nameOccName name
-              ctyp = occNameToComKind Nothing occ
-              pn = ppr name
-              ty = ppr <$> typ
-              thisModName = case nameModule_maybe name of
-                Nothing -> Left $ nameSrcSpan name
-                Just m -> Right $ ppr m
-
-          compls = if T.null prefixModule
-            then localCompls ++ unqualCompls
-            else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
-
-      filtListWith f list =
-        [ f label
-        | label <- Fuzzy.simpleFilter fullPrefix list
-        , enteredQual `T.isPrefixOf` label
-        ]
-
-      filtListWithSnippet f list suffix =
-        [ toggleSnippets caps withSnippets (f label (snippet <> suffix))
-        | (snippet, label) <- list
-        , Fuzzy.test fullPrefix label
-        ]
-
-      filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
-      filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
-      filtOptsCompls   = filtListWith mkExtCompl
-      filtKeywordCompls
-          | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
-          | otherwise = []
-
-      stripLeading :: Char -> String -> String
-      stripLeading _ [] = []
-      stripLeading c (s:ss)
-        | s == c = ss
-        | otherwise = s:ss
-
-      result
-        | "import " `T.isPrefixOf` fullLine
-        = filtImportCompls
-        -- we leave this condition here to avoid duplications and return empty list
-        -- since HLS implements this completion (#haskell-language-server/pull/662)
-        | "{-# language" `T.isPrefixOf` T.toLower fullLine
-        = []
-        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
-        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
-        | "{-# " `T.isPrefixOf` fullLine
-        = filtPragmaCompls (pragmaSuffix fullLine)
-        | otherwise
-        = let uniqueFiltCompls = nubOrdOn insertText filtCompls
-          in filtModNameCompls ++ map (toggleSnippets caps withSnippets
-                                         . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls
-                               ++ filtKeywordCompls
-  return result
-
-
--- ---------------------------------------------------------------------
--- helper functions for pragmas
--- ---------------------------------------------------------------------
-
-validPragmas :: [(T.Text, T.Text)]
-validPragmas =
-  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE")
-  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC")
-  , ("INLINE ${1:function}"           , "INLINE")
-  , ("NOINLINE ${1:function}"         , "NOINLINE")
-  , ("INLINABLE ${1:function}"        , "INLINABLE")
-  , ("WARNING ${1:message}"           , "WARNING")
-  , ("DEPRECATED ${1:message}"        , "DEPRECATED")
-  , ("ANN ${1:annotation}"            , "ANN")
-  , ("RULES"                          , "RULES")
-  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE")
-  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
-  ]
-
-pragmaSuffix :: T.Text -> T.Text
-pragmaSuffix fullLine
-  |  "}" `T.isSuffixOf` fullLine = mempty
-  | otherwise = " #-}"
-
--- ---------------------------------------------------------------------
--- helper functions for infix backticks
--- ---------------------------------------------------------------------
-
-hasTrailingBacktick :: T.Text -> Position -> Bool
-hasTrailingBacktick line Position { _character }
-    | T.length line > _character = (line `T.index` _character) == '`'
-    | otherwise = False
-
-isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
-isUsedAsInfix line prefixMod prefixText pos
-    | hasClosingBacktick && hasOpeningBacktick = Just Surrounded
-    | hasOpeningBacktick = Just LeftSide
-    | otherwise = Nothing
-  where
-    hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
-    hasClosingBacktick = hasTrailingBacktick line pos
-
-openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
-openingBacktick line prefixModule prefixText Position { _character }
-  | backtickIndex < 0 = False
-  | otherwise = (line `T.index` backtickIndex) == '`'
-    where
-    backtickIndex :: Int
-    backtickIndex =
-      let
-          prefixLength = T.length prefixText
-          moduleLength = if prefixModule == ""
-                    then 0
-                    else T.length prefixModule + 1 {- Because of "." -}
-      in
-        -- Points to the first letter of either the module or prefix text
-        _character - (prefixLength + moduleLength) - 1
-
-
--- ---------------------------------------------------------------------
-
--- | Under certain circumstance GHC generates some extra stuff that we
--- don't want in the autocompleted symbols
-stripAutoGenerated :: CompItem -> CompItem
-stripAutoGenerated ci =
-    ci {label = stripPrefix (label ci)}
-    {- When e.g. DuplicateRecordFields is enabled, compiler generates
-    names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
-    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
-    -}
-
--- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
-
-stripPrefix :: T.Text -> T.Text
-stripPrefix name = T.takeWhile (/=':') $ go prefixes
-  where
-    go [] = name
-    go (p:ps)
-      | T.isPrefixOf p name = T.drop (T.length p) name
-      | otherwise = go ps
-
--- | Prefixes that can occur in a GHC OccName
-prefixes :: [T.Text]
-prefixes =
-  [
-    -- long ones
-    "$con2tag_"
-  , "$tag2con_"
-  , "$maxtag_"
-
-  -- four chars
-  , "$sel:"
-  , "$tc'"
-
-  -- three chars
-  , "$dm"
-  , "$co"
-  , "$tc"
-  , "$cp"
-  , "$fx"
-
-  -- two chars
-  , "$W"
-  , "$w"
-  , "$m"
-  , "$b"
-  , "$c"
-  , "$d"
-  , "$i"
-  , "$s"
-  , "$f"
-  , "$r"
-  , "C:"
-  , "N:"
-  , "D:"
-  , "$p"
-  , "$L"
-  , "$f"
-  , "$t"
-  , "$c"
-  , "$m"
-  ]
-
-
-safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])
-safeTyThingForRecord (AnId _) = Nothing
-safeTyThingForRecord (AConLike dc) =
-    let ctxStr =   T.pack . showGhc . occName . conLikeName $ dc
-        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc
-    in
-        Just (ctxStr, field_names)
-safeTyThingForRecord _ = Nothing
-
-mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
-mkRecordSnippetCompItem ctxStr compl mn docs imp = r
-  where
-      r  = CI {
-            compKind = CiSnippet
-          , insertText = buildSnippet
-          , importedFrom = importedFrom
-          , typeText = Nothing
-          , label = ctxStr
-          , isInfix = Nothing
-          , docs = docs
-          , isTypeCompl = False
-          , additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr)
-          }
-
-      placeholder_pairs = zip compl ([1..]::[Int])
-      snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs
-      snippet = T.intercalate (T.pack ", ") snippet_parts
-      buildSnippet = ctxStr <> " {" <> snippet <> "}"
-      importedFrom = Right mn
+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs#-}++#include "ghc-api-version.h"++-- Mostly taken from "haskell-ide-engine"+module Development.IDE.Plugin.Completions.Logic (+  CachedCompletions+, cacheDataProducer+, localCompletionsForParsedModule+, WithSnippets(..)+, getCompletions+) where++import Control.Applicative+import Data.Char (isAlphaNum, isUpper)+import Data.Generics+import Data.List.Extra as List hiding (stripPrefix)+import qualified Data.Map  as Map++import Data.Maybe (listToMaybe, fromMaybe, mapMaybe)+import qualified Data.Text as T+import qualified Text.Fuzzy as Fuzzy++import HscTypes+import Name+import RdrName+import Type+import Packages+#if MIN_GHC_API_VERSION(8,10,0)+import Predicate (isDictTy)+import Pair+import Coercion+#endif++import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import qualified Language.Haskell.LSP.VFS as VFS+import Development.IDE.Core.Compile+import Development.IDE.Core.PositionMapping+import Development.IDE.Plugin.Completions.Types+import Development.IDE.Spans.Documentation+import Development.IDE.Spans.LocalBindings+import Development.IDE.GHC.Compat as GHC+import Development.IDE.GHC.Error+import Development.IDE.Types.Options+import Development.IDE.Spans.Common+import Development.IDE.GHC.Util+import Outputable (Outputable)+import qualified Data.Set as Set+import ConLike++import GhcPlugins (+    flLabel,+    unpackFS)+import Data.Either (fromRight)++-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs++-- | A context of a declaration in the program+-- e.g. is the declaration a type declaration or a value declaration+-- Used for determining which code completions to show+-- TODO: expand this with more contexts like classes or instances for+-- smarter code completion+data Context = TypeContext+             | ValueContext+             | ModuleContext String -- ^ module context with module name+             | ImportContext String -- ^ import context with module name+             | ImportListContext String -- ^ import list context with module name+             | ImportHidingContext String -- ^ import hiding context with module name+             | ExportContext -- ^ List of exported identifiers from the current module+  deriving (Show, Eq)++-- | Generates a map of where the context is a type and where the context is a value+-- i.e. where are the value decls and the type decls+getCContext :: Position -> ParsedModule -> Maybe Context+getCContext pos pm+  | Just (L r modName) <- moduleHeader+  , pos `isInsideSrcSpan` r+  = Just (ModuleContext (moduleNameString modName))++  | Just (L r _) <- exportList+  , pos `isInsideSrcSpan` r+  = Just ExportContext++  | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl+  = Just ctx++  | Just ctx <- something (Nothing `mkQ` importGo) imports+  = Just ctx++  | otherwise+  = Nothing++  where decl = hsmodDecls $ unLoc $ pm_parsed_source pm+        moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm+        exportList = hsmodExports $ unLoc $ pm_parsed_source pm+        imports = hsmodImports $ unLoc $ pm_parsed_source pm++        go :: LHsDecl GhcPs -> Maybe Context+        go (L r SigD {})+          | pos `isInsideSrcSpan` r = Just TypeContext+          | otherwise = Nothing+        go (L r GHC.ValD {})+          | pos `isInsideSrcSpan` r = Just ValueContext+          | otherwise = Nothing+        go _ = Nothing++        goInline :: GHC.LHsType GhcPs -> Maybe Context+        goInline (GHC.L r _)+          | pos `isInsideSrcSpan` r = Just TypeContext+        goInline _ = Nothing++        importGo :: GHC.LImportDecl GhcPs -> Maybe Context+        importGo (L r impDecl)+          | pos `isInsideSrcSpan` r+          = importInline importModuleName (ideclHiding impDecl)+          <|> Just (ImportContext importModuleName)++          | otherwise = Nothing+          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl++        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context+        importInline modName (Just (True, L r _))+          | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName+          | otherwise = Nothing+        importInline modName (Just (False, L r _))+          | pos `isInsideSrcSpan` r = Just $ ImportListContext modName+          | otherwise = Nothing+        importInline _ _ = Nothing++occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind+occNameToComKind ty oc+  | isVarOcc  oc = case occNameString oc of+                     i:_ | isUpper i -> CiConstructor+                     _               -> CiFunction+  | isTcOcc   oc = case ty of+                     Just t+                       | "Constraint" `T.isSuffixOf` t+                       -> CiClass+                     _ -> CiStruct+  | isDataOcc oc = CiConstructor+  | otherwise    = CiVariable+++showModName :: ModuleName -> T.Text+showModName = T.pack . moduleNameString++-- mkCompl :: IdeOptions -> CompItem -> CompletionItem+-- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =+--   CompletionItem label kind (List []) ((colon <>) <$> typeText)+--     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')+--     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+--     Nothing Nothing Nothing Nothing Nothing++mkCompl :: IdeOptions -> CompItem -> CompletionItem+mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} =+  CompletionItem {_label = label,+                  _kind = kind,+                  _tags = Nothing,+                  _detail = (colon <>) <$> typeText,+                  _documentation = documentation,+                  _deprecated = Nothing,+                  _preselect = Nothing,+                  _sortText = Nothing,+                  _filterText = Nothing,+                  _insertText = Just insertText,+                  _insertTextFormat = Just Snippet,+                  _textEdit = Nothing,+                  _additionalTextEdits = List <$> additionalTextEdits,+                  _commitCharacters = Nothing,+                  _command = Nothing,+                  _xdata = Nothing}++  where kind = Just compKind+        docs' = imported : spanDocToMarkdown docs+        imported = case importedFrom of+          Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"+          Right mod -> "*Defined in '" <> mod <> "'*\n"+        colon = if optNewColonConvention then ": " else ":: "+        documentation = Just $ CompletionDocMarkup $+                        MarkupContent MkMarkdown $+                        T.intercalate sectionSeparator docs'++mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..}+  where+    compKind = occNameToComKind typeText $ occName origName+    importedFrom = Right $ showModName origMod+    isTypeCompl = isTcOcc $ occName origName+    label = T.pack $ showGhc origName+    insertText = case isInfix of+            Nothing -> case getArgText <$> thingType of+                            Nothing -> label+                            Just argText -> label <> " " <> argText+            Just LeftSide -> label <> "`"++            Just Surrounded -> label+    typeText+          | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)+          | otherwise = Nothing+    additionalTextEdits = imp >>= extendImportList (showGhc origName)++    stripForall :: T.Text -> T.Text+    stripForall t+      | T.isPrefixOf "forall" t =+        -- We drop 2 to remove the '.' and the space after it+        T.drop 2 (T.dropWhile (/= '.') t)+      | otherwise               = t++    getArgText :: Type -> T.Text+    getArgText typ = argText+      where+        argTypes = getArgs typ+        argText :: T.Text+        argText =  mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes+        snippet :: Int -> Type -> T.Text+        snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"+        getArgs :: Type -> [Type]+        getArgs t+          | isPredTy t = []+          | isDictTy t = []+          | isForAllTy t = getArgs $ snd (splitForAllTys t)+          | isFunTy t =+            let (args, ret) = splitFunTys t+              in if isForAllTy ret+                  then getArgs ret+                  else Prelude.filter (not . isDictTy) args+          | isPiTy t = getArgs $ snd (splitPiTys t)+#if MIN_GHC_API_VERSION(8,10,0)+          | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t+          = getArgs t+#else+          | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)+#endif+          | otherwise = []++mkModCompl :: T.Text -> CompletionItem+mkModCompl label =+  CompletionItem label (Just CiModule) Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing++mkImportCompl :: T.Text -> T.Text -> CompletionItem+mkImportCompl enteredQual label =+  CompletionItem m (Just CiModule) Nothing (Just label)+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing+  where+    m = fromMaybe "" (T.stripPrefix enteredQual label)++mkExtCompl :: T.Text -> CompletionItem+mkExtCompl label =+  CompletionItem label (Just CiKeyword) Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing++mkPragmaCompl :: T.Text -> T.Text -> CompletionItem+mkPragmaCompl label insertText =+  CompletionItem label (Just CiKeyword) Nothing Nothing+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+    Nothing Nothing Nothing Nothing Nothing++extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit]+extendImportList name lDecl = let+    f (Just range) ImportDecl {ideclHiding} = case ideclHiding of+        Just (False, x)+          | Set.notMember name (Set.fromList [show y| y <- unLoc x])+          -> let+            start_pos = _end range+            new_start_pos = start_pos {_character = _character start_pos - 1}+            -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules+            new_range = Range new_start_pos new_start_pos+            -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$)+            alpha = all isAlphaNum $ filter (/= '_') name+            result = if alpha then name ++ ", "+                else "(" ++ name ++ "), "+            in Just [TextEdit new_range (T.pack result)]+          | otherwise -> Nothing+        _ -> Nothing  -- hiding import list and no list+    f _ _ = Nothing+    src_span = srcSpanToRange . getLoc $ lDecl+    in f src_span . unLoc $ lDecl+++cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions+cacheDataProducer packageState curMod rdrEnv limports deps = do+  let dflags = hsc_dflags packageState+      curModName = moduleName curMod++      iDeclToModName :: ImportDecl name -> ModuleName+      iDeclToModName = unLoc . ideclName++      asNamespace :: ImportDecl name -> ModuleName+      asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)+      -- Full canonical names of imported modules+      importDeclerations = map unLoc limports++      -- The list of all importable Modules from all packages+      moduleNames = map showModName (listVisibleModuleNames dflags)++      -- The given namespaces for the imported modules (ie. full name, or alias if used)+      allModNamesAsNS = map (showModName . asNamespace) importDeclerations++      rdrElts = globalRdrEnvElts rdrEnv++      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b+      foldMapM f xs = foldr step return xs mempty where+        step x r z = f x >>= \y -> r $! z `mappend` y++      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)+      getCompls = foldMapM getComplsForOne++      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)+      getComplsForOne (GRE n _ True _) =+          (, mempty) <$> toCompItem curMod curModName n Nothing+      getComplsForOne (GRE n _ False prov) =+        flip foldMapM (map is_decl prov) $ \spec -> do+          compItem <- toCompItem curMod (is_mod spec) n Nothing+          let unqual+                | is_qual spec = []+                | otherwise = compItem+              qual+                | is_qual spec = Map.singleton asMod compItem+                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]+              asMod = showModName (is_as spec)+              origMod = showModName (is_mod spec)+          return (unqual,QualCompls qual)++      toCompItem :: Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]+      toCompItem m mn n imp' = do+        docs <- getDocumentationTryGhc packageState curMod deps n+        ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do+                name' <- lookupName packageState m n+                return $ name' >>= safeTyThingType+        -- use the same pass to also capture any Record snippets that we can collect+        record_ty <- catchSrcErrors (hsc_dflags packageState) "record-completion" $ do+                name' <- lookupName packageState m n+                return $ name' >>= safeTyThingForRecord++        let recordCompls = case fromRight Nothing record_ty of+                Just (ctxStr, flds) -> case flds of+                    [] -> []+                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp']+                Nothing -> []++        return $ mkNameCompItem n mn (fromRight Nothing ty) Nothing docs imp'+                 : recordCompls++  (unquals,quals) <- getCompls rdrElts++  return $ CC+    { allModNamesAsNS = allModNamesAsNS+    , unqualCompls = unquals+    , qualCompls = quals+    , importableModules = moduleNames+    }+++-- | Produces completions from the top level declarations of a module.+localCompletionsForParsedModule :: ParsedModule -> CachedCompletions+localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =+    CC { allModNamesAsNS = mempty+       , unqualCompls = compls+       , qualCompls = mempty+       , importableModules = mempty+        }+  where+    typeSigIds = Set.fromList+        [ id+            | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls+            , L _ id <- ids+            ]+    hasTypeSig = (`Set.member` typeSigIds) . unLoc++    compls = concat+        [ case decl of+            SigD _ (TypeSig _ ids typ) ->+                [mkComp id CiFunction (Just $ ppr typ) | id <- ids]+            ValD _ FunBind{fun_id} ->+                [ mkComp fun_id CiFunction Nothing+                | not (hasTypeSig fun_id)+                ]+            ValD _ PatBind{pat_lhs} ->+                [mkComp id CiVariable Nothing+                | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]+            TyClD _ ClassDecl{tcdLName, tcdSigs} ->+                mkComp tcdLName CiClass Nothing :+                [ mkComp id CiFunction (Just $ ppr typ)+                | L _ (TypeSig _ ids typ) <- tcdSigs+                , id <- ids]+            TyClD _ x ->+                let generalCompls = [mkComp id cl Nothing+                        | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x+                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]+                    -- here we only have to look at the outermost type+                    recordCompls = findRecordCompl pm thisModName x+                in+                   -- the constructors and snippets will be duplicated here giving the user 2 choices.+                   generalCompls ++ recordCompls+            ForD _ ForeignImport{fd_name,fd_sig_ty} ->+                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]+            ForD _ ForeignExport{fd_name,fd_sig_ty} ->+                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]+            _ -> []+            | L _ decl <- hsmodDecls+        ]++    mkComp n ctyp ty =+        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing+      where+        pn = ppr n+        doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)++    thisModName = ppr hsmodName++findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]+findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result+    where+        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing+                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn+                 , Just  con_details <- [getFlds con_args]+                 , let field_names = mapMaybe extract con_details+                 , let field_labels = T.pack . showGhc . unLoc <$> field_names+                 , (not . List.null) field_labels+                 ]+        doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)++        getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]+        getFlds conArg = case conArg of+                             RecCon rec -> Just $ unLoc <$> unLoc rec+                             PrefixCon _ -> Just []+                             _ -> Nothing++        extract ConDeclField{..}+             -- TODO: Why is cd_fld_names a list?+            | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name+            | otherwise = Nothing+        -- XConDeclField+        extract _ = Nothing+findRecordCompl _ _ _ = []++ppr :: Outputable a => a -> T.Text+ppr = T.pack . prettyPrint++newtype WithSnippets = WithSnippets Bool++toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x+  | with && supported = x+  | otherwise = x { _insertTextFormat = Just PlainText+                  , _insertText       = Nothing+                  }+  where+    supported =+      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)++-- | Returns the cached completions for the given module and position.+getCompletions+    :: IdeOptions+    -> CachedCompletions+    -> Maybe (ParsedModule, PositionMapping)+    -> (Bindings, PositionMapping)+    -> VFS.PosPrefixInfo+    -> ClientCapabilities+    -> WithSnippets+    -> IO [CompletionItem]+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules}+               maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do+  let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo+      enteredQual = if T.null prefixModule then "" else prefixModule <> "."+      fullPrefix  = enteredQual <> prefixText++      {- correct the position by moving 'foo :: Int -> String ->    '+                                                                    ^+          to                             'foo :: Int -> String ->    '+                                                              ^+      -}+      pos = VFS.cursorPos prefixInfo++      filtModNameCompls =+        map mkModCompl+          $ mapMaybe (T.stripPrefix enteredQual)+          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS++      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False+        where++          mcc = case maybe_parsed of+            Nothing -> Nothing+            Just (pm, pmapping) ->+              let PositionMapping pDelta = pmapping+                  position' = fromDelta pDelta pos+                  lpos = lowerRange position'+                  hpos = upperRange position'+              in getCContext lpos pm <|> getCContext hpos pm++          -- completions specific to the current context+          ctxCompls' = case mcc of+                        Nothing -> compls+                        Just TypeContext -> filter isTypeCompl compls+                        Just ValueContext -> filter (not . isTypeCompl) compls+                        Just _ -> filter (not . isTypeCompl) compls+          -- Add whether the text to insert has backticks+          ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'++          infixCompls :: Maybe Backtick+          infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos++          PositionMapping bDelta = bmapping+          oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo+          startLoc = lowerRange oldPos+          endLoc = upperRange oldPos+          localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc+          localBindsToCompItem :: Name -> Maybe Type -> CompItem+          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing+            where+              occ = nameOccName name+              ctyp = occNameToComKind Nothing occ+              pn = ppr name+              ty = ppr <$> typ+              thisModName = case nameModule_maybe name of+                Nothing -> Left $ nameSrcSpan name+                Just m -> Right $ ppr m++          compls = if T.null prefixModule+            then localCompls ++ unqualCompls+            else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls++      filtListWith f list =+        [ f label+        | label <- Fuzzy.simpleFilter fullPrefix list+        , enteredQual `T.isPrefixOf` label+        ]++      filtListWithSnippet f list suffix =+        [ toggleSnippets caps withSnippets (f label (snippet <> suffix))+        | (snippet, label) <- list+        , Fuzzy.test fullPrefix label+        ]++      filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules+      filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas+      filtOptsCompls   = filtListWith mkExtCompl+      filtKeywordCompls+          | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)+          | otherwise = []++      stripLeading :: Char -> String -> String+      stripLeading _ [] = []+      stripLeading c (s:ss)+        | s == c = ss+        | otherwise = s:ss++      result+        | "import " `T.isPrefixOf` fullLine+        = filtImportCompls+        -- we leave this condition here to avoid duplications and return empty list+        -- since HLS implements this completion (#haskell-language-server/pull/662)+        | "{-# language" `T.isPrefixOf` T.toLower fullLine+        = []+        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine+        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)+        | "{-# " `T.isPrefixOf` fullLine+        = filtPragmaCompls (pragmaSuffix fullLine)+        | otherwise+        = let uniqueFiltCompls = nubOrdOn insertText filtCompls+          in filtModNameCompls ++ map (toggleSnippets caps withSnippets+                                         . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls+                               ++ filtKeywordCompls+  return result+++-- ---------------------------------------------------------------------+-- helper functions for pragmas+-- ---------------------------------------------------------------------++validPragmas :: [(T.Text, T.Text)]+validPragmas =+  [ ("LANGUAGE ${1:extension}"        , "LANGUAGE")+  , ("OPTIONS_GHC -${1:option}"       , "OPTIONS_GHC")+  , ("INLINE ${1:function}"           , "INLINE")+  , ("NOINLINE ${1:function}"         , "NOINLINE")+  , ("INLINABLE ${1:function}"        , "INLINABLE")+  , ("WARNING ${1:message}"           , "WARNING")+  , ("DEPRECATED ${1:message}"        , "DEPRECATED")+  , ("ANN ${1:annotation}"            , "ANN")+  , ("RULES"                          , "RULES")+  , ("SPECIALIZE ${1:function}"       , "SPECIALIZE")+  , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")+  ]++pragmaSuffix :: T.Text -> T.Text+pragmaSuffix fullLine+  |  "}" `T.isSuffixOf` fullLine = mempty+  | otherwise = " #-}"++-- ---------------------------------------------------------------------+-- helper functions for infix backticks+-- ---------------------------------------------------------------------++hasTrailingBacktick :: T.Text -> Position -> Bool+hasTrailingBacktick line Position { _character }+    | T.length line > _character = (line `T.index` _character) == '`'+    | otherwise = False++isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick+isUsedAsInfix line prefixMod prefixText pos+    | hasClosingBacktick && hasOpeningBacktick = Just Surrounded+    | hasOpeningBacktick = Just LeftSide+    | otherwise = Nothing+  where+    hasOpeningBacktick = openingBacktick line prefixMod prefixText pos+    hasClosingBacktick = hasTrailingBacktick line pos++openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool+openingBacktick line prefixModule prefixText Position { _character }+  | backtickIndex < 0 = False+  | otherwise = (line `T.index` backtickIndex) == '`'+    where+    backtickIndex :: Int+    backtickIndex =+      let+          prefixLength = T.length prefixText+          moduleLength = if prefixModule == ""+                    then 0+                    else T.length prefixModule + 1 {- Because of "." -}+      in+        -- Points to the first letter of either the module or prefix text+        _character - (prefixLength + moduleLength) - 1+++-- ---------------------------------------------------------------------++-- | Under certain circumstance GHC generates some extra stuff that we+-- don't want in the autocompleted symbols+stripAutoGenerated :: CompItem -> CompItem+stripAutoGenerated ci =+    ci {label = stripPrefix (label ci)}+    {- When e.g. DuplicateRecordFields is enabled, compiler generates+    names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors+    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation+    -}++-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.++stripPrefix :: T.Text -> T.Text+stripPrefix name = T.takeWhile (/=':') $ go prefixes+  where+    go [] = name+    go (p:ps)+      | T.isPrefixOf p name = T.drop (T.length p) name+      | otherwise = go ps++-- | Prefixes that can occur in a GHC OccName+prefixes :: [T.Text]+prefixes =+  [+    -- long ones+    "$con2tag_"+  , "$tag2con_"+  , "$maxtag_"++  -- four chars+  , "$sel:"+  , "$tc'"++  -- three chars+  , "$dm"+  , "$co"+  , "$tc"+  , "$cp"+  , "$fx"++  -- two chars+  , "$W"+  , "$w"+  , "$m"+  , "$b"+  , "$c"+  , "$d"+  , "$i"+  , "$s"+  , "$f"+  , "$r"+  , "C:"+  , "N:"+  , "D:"+  , "$p"+  , "$L"+  , "$f"+  , "$t"+  , "$c"+  , "$m"+  ]+++safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])+safeTyThingForRecord (AnId _) = Nothing+safeTyThingForRecord (AConLike dc) =+    let ctxStr =   T.pack . showGhc . occName . conLikeName $ dc+        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc+    in+        Just (ctxStr, field_names)+safeTyThingForRecord _ = Nothing++mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkRecordSnippetCompItem ctxStr compl mn docs imp = r+  where+      r  = CI {+            compKind = CiSnippet+          , insertText = buildSnippet+          , importedFrom = importedFrom+          , typeText = Nothing+          , label = ctxStr+          , isInfix = Nothing+          , docs = docs+          , isTypeCompl = False+          , additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr)+          }++      placeholder_pairs = zip compl ([1..]::[Int])+      snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs+      snippet = T.intercalate (T.pack ", ") snippet_parts+      buildSnippet = ctxStr <> " {" <> snippet <> "}"+      importedFrom = Right mn
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -1,60 +1,60 @@-module Development.IDE.Plugin.Completions.Types (
-  module Development.IDE.Plugin.Completions.Types
-) where
-
-import           Control.DeepSeq
-import qualified Data.Map  as Map
-import qualified Data.Text as T
-import SrcLoc
-
-import Development.IDE.Spans.Common
-import Language.Haskell.LSP.Types (TextEdit, CompletionItemKind)
-
--- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
-
-data Backtick = Surrounded | LeftSide
-  deriving (Eq, Ord, Show)
-
-data CompItem = CI
-  { compKind     :: CompletionItemKind
-  , insertText   :: T.Text         -- ^ Snippet for the completion
-  , importedFrom :: Either SrcSpan T.Text         -- ^ From where this item is imported from.
-  , typeText     :: Maybe T.Text   -- ^ Available type information.
-  , label        :: T.Text         -- ^ Label to display to the user.
-  , isInfix      :: Maybe Backtick -- ^ Did the completion happen
-                                   -- in the context of an infix notation.
-  , docs         :: SpanDoc        -- ^ Available documentation.
-  , isTypeCompl  :: Bool
-  , additionalTextEdits :: Maybe [TextEdit]
-  }
-  deriving (Eq, Show)
-
--- Associates a module's qualifier with its members
-newtype QualCompls
-  = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }
-  deriving Show
-instance Semigroup QualCompls where
-  (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b
-instance Monoid QualCompls where
-  mempty = QualCompls Map.empty
-  mappend = (Prelude.<>)
-
--- | End result of the completions
-data CachedCompletions = CC
-  { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.
-                                -- Prelude is a single module
-  , unqualCompls :: [CompItem]  -- ^ All Possible completion items
-  , qualCompls :: QualCompls    -- ^ Completion items associated to
-                                -- to a specific module name.
-  , importableModules :: [T.Text] -- ^ All modules that may be imported.
-  } deriving Show
-
-instance NFData CachedCompletions where
-    rnf = rwhnf
-
-instance Monoid CachedCompletions where
-    mempty = CC 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')
+module Development.IDE.Plugin.Completions.Types (+  module Development.IDE.Plugin.Completions.Types+) where++import           Control.DeepSeq+import qualified Data.Map  as Map+import qualified Data.Text as T+import SrcLoc++import Development.IDE.Spans.Common+import Language.Haskell.LSP.Types (TextEdit, CompletionItemKind)++-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs++data Backtick = Surrounded | LeftSide+  deriving (Eq, Ord, Show)++data CompItem = CI+  { compKind     :: CompletionItemKind+  , insertText   :: T.Text         -- ^ Snippet for the completion+  , importedFrom :: Either SrcSpan T.Text         -- ^ From where this item is imported from.+  , typeText     :: Maybe T.Text   -- ^ Available type information.+  , label        :: T.Text         -- ^ Label to display to the user.+  , isInfix      :: Maybe Backtick -- ^ Did the completion happen+                                   -- in the context of an infix notation.+  , docs         :: SpanDoc        -- ^ Available documentation.+  , isTypeCompl  :: Bool+  , additionalTextEdits :: Maybe [TextEdit]+  }+  deriving (Eq, Show)++-- Associates a module's qualifier with its members+newtype QualCompls+  = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }+  deriving Show+instance Semigroup QualCompls where+  (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b+instance Monoid QualCompls where+  mempty = QualCompls Map.empty+  mappend = (Prelude.<>)++-- | End result of the completions+data CachedCompletions = CC+  { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.+                                -- Prelude is a single module+  , unqualCompls :: [CompItem]  -- ^ All Possible completion items+  , qualCompls :: QualCompls    -- ^ Completion items associated to+                                -- to a specific module name.+  , importableModules :: [T.Text] -- ^ All modules that may be imported.+  } deriving Show++instance NFData CachedCompletions where+    rnf = rwhnf++instance Monoid CachedCompletions where+    mempty = CC 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')
src/Development/IDE/Plugin/HLS.hs view
@@ -1,472 +1,472 @@-{-# LANGUAGE DeriveAnyClass #-}
-
-module Development.IDE.Plugin.HLS
-    (
-      asGhcIdePlugin
-    ) where
-
-import           Control.Exception(SomeException, catch)
-import           Control.Lens ( (^.) )
-import           Control.Monad
-import qualified Data.Aeson as J
-import           Data.Either
-import qualified Data.List                     as List
-import qualified Data.Map  as Map
-import           Data.Maybe
-import qualified Data.Text                     as T
-import           Development.IDE.Core.Shake
-import           Development.IDE.LSP.Server
-import           Development.IDE.Plugin
-import           Development.IDE.Plugin.HLS.Formatter
-import           GHC.Generics
-import           Ide.Plugin.Config
-import           Ide.Types as HLS
-import qualified Language.Haskell.LSP.Core as LSP
-import           Language.Haskell.LSP.Messages
-import           Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Types              as J
-import qualified Language.Haskell.LSP.Types.Capabilities as C
-import           Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)
-import qualified Language.Haskell.LSP.VFS                as VFS
-import           Text.Regex.TDFA.Text()
-import Development.Shake (Rules)
-import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
-import Development.IDE.Types.Logger (logInfo)
-
--- ---------------------------------------------------------------------
-
--- | Map a set of plugins to the underlying ghcide engine.  Main point is
--- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message
--- category ('Notifaction', 'Request' etc).
-asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config
-asGhcIdePlugin mp =
-    mkPlugin rulesPlugins (Just . HLS.pluginRules) <>
-    mkPlugin executeCommandPlugins (Just . pluginCommands) <>
-    mkPlugin codeActionPlugins     pluginCodeActionProvider <>
-    mkPlugin codeLensPlugins       pluginCodeLensProvider <>
-    -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider
-    mkPlugin hoverPlugins          pluginHoverProvider <>
-    mkPlugin symbolsPlugins        pluginSymbolsProvider <>
-    mkPlugin formatterPlugins      pluginFormattingProvider <>
-    mkPlugin completionsPlugins    pluginCompletionProvider <>
-    mkPlugin renamePlugins         pluginRenameProvider
-    where
-        justs (p, Just x)  = [(p, x)]
-        justs (_, Nothing) = []
-
-        ls = Map.toList (ipMap mp)
-
-        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config
-        mkPlugin maker selector =
-          case concatMap (\(pid, p) -> justs (pid, selector p)) ls of
-            -- If there are no plugins that provide a descriptor, use mempty to
-            -- create the plugin – otherwise we we end up declaring handlers for
-            -- capabilities that there are no plugins for
-            [] -> mempty
-            xs -> maker xs
-
--- ---------------------------------------------------------------------
-
-rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
-rulesPlugins rs = Plugin rules mempty
-    where
-        rules = foldMap snd rs
-
-codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config
-codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas)
-
-codeActionRules :: Rules ()
-codeActionRules = mempty
-
-codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config
-codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x
-    { LSP.codeActionHandler
-        = withResponse RspCodeAction (makeCodeAction cas)
-    }
-
-makeCodeAction :: [(PluginId, CodeActionProvider IdeState)]
-      -> LSP.LspFuncs Config -> IdeState
-      -> CodeActionParams
-      -> IO (Either ResponseError (List CAResult))
-makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do
-    let caps = LSP.clientCapabilities lf
-        unL (List ls) = ls
-        makeAction (pid,provider) = do
-          pluginConfig <- getPluginConfig lf pid
-          if pluginEnabled pluginConfig plcCodeActionsOn
-            then provider lf ideState pid docId range context
-            else return $ Right (List [])
-    r <- mapM makeAction cas
-    let actions = filter wasRequested . foldMap unL $ rights r
-    res <- send caps actions
-    return $ Right res
-  where
-    wasRequested :: CAResult -> Bool
-    wasRequested (CACommand _) = True
-    wasRequested (CACodeAction ca)
-      | Nothing <- only context = True
-      | Just (List allowed) <- only context
-      , Just caKind <- ca ^. kind = caKind `elem` allowed
-      | otherwise = False
-
-    wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)
-    wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd)
-    wrapCodeAction caps (CACodeAction action) = do
-
-      let (C.ClientCapabilities _ textDocCaps _ _) = caps
-      let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport
-
-      case literalSupport of
-        Nothing -> do
-            let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]
-            cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)
-            return $ Just (CACommand cmd)
-        Just _ -> return $ Just (CACodeAction action)
-
-    send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)
-    send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions
-
-data FallbackCodeActionParams =
-  FallbackCodeActionParams
-    { fallbackWorkspaceEdit :: Maybe WorkspaceEdit
-    , fallbackCommand       :: Maybe Command
-    }
-  deriving (Generic, J.ToJSON, J.FromJSON)
-
--- -----------------------------------------------------------
-
-codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config
-codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas)
-
-codeLensRules :: Rules ()
-codeLensRules = mempty
-
-codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config
-codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x
-    { LSP.codeLensHandler
-        = withResponse RspCodeLens (makeCodeLens cas)
-    }
-
-makeCodeLens :: [(PluginId, CodeLensProvider IdeState)]
-      -> LSP.LspFuncs Config
-      -> IdeState
-      -> CodeLensParams
-      -> IO (Either ResponseError (List CodeLens))
-makeCodeLens cas lf ideState params = do
-    logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ
-    let
-      makeLens (pid, provider) = do
-          pluginConfig <- getPluginConfig lf pid
-          r <- if pluginEnabled pluginConfig plcCodeLensOn
-                 then provider lf ideState pid params
-                 else return $ Right (List [])
-          return (pid, r)
-      breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])
-      breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls)
-        where
-          doOneLeft (pid, Left err) = [(pid,err)]
-          doOneLeft (_, Right _) = []
-
-          doOneRight (pid, Right a) = [(pid,a)]
-          doOneRight (_, Left _) = []
-
-    r <- mapM makeLens cas
-    case breakdown r of
-        ([],[]) -> return $ Right $ List []
-        (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing
-        (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs)
-
--- -----------------------------------------------------------
-
-executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
-executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)
-
-executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config
-executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs)
-    }
-
-makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState
-makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do
-  let
-      pluginMap = Map.fromList ecs
-      parseCmdId :: T.Text -> Maybe (PluginId, CommandId)
-      parseCmdId x = case T.splitOn ":" x of
-        [plugin, command] -> Just (PluginId plugin, CommandId command)
-        [_, plugin, command] -> Just (PluginId plugin, CommandId command)
-        _ -> Nothing
-
-      execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
-      execCmd (ExecuteCommandParams cmdId args _) = do
-        -- The parameters to the HIE command are always the first element
-        let cmdParams :: J.Value
-            cmdParams = case args of
-             Just (J.List (x:_)) -> x
-             _ -> J.Null
-
-        case parseCmdId cmdId of
-          -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions
-          Just ("hls", "fallbackCodeAction") ->
-            case J.fromJSON cmdParams of
-              J.Success (FallbackCodeActionParams mEdit mCmd) -> do
-
-                -- Send off the workspace request if it has one
-                forM_ mEdit $ \edit -> do
-                  let eParams = J.ApplyWorkspaceEditParams edit
-                  reqId <- LSP.getNextReqId lf
-                  LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams
-
-                case mCmd of
-                  -- If we have a command, continue to execute it
-                  Just (J.Command _ innerCmdId innerArgs)
-                      -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing)
-                  Nothing -> return (Right J.Null, Nothing)
-
-              J.Error _str -> return (Right J.Null, Nothing)
-
-          -- Just an ordinary HIE command
-          Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams
-
-          -- Couldn't parse the command identifier
-          _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing)
-
-  execCmd
-
-
--- -----------------------------------------------------------
-wrapUnhandledExceptions ::
-    (a -> IO (Either ResponseError J.Value, Maybe b)) ->
-       a -> IO (Either ResponseError J.Value, Maybe b)
-wrapUnhandledExceptions action input =
-    catch (action input) $ \(e::SomeException) -> do
-        let resp = ResponseError InternalError (T.pack $ show e) Nothing
-        return (Left resp, Nothing)
-
-
--- | Runs a plugin command given a PluginId, CommandId and
--- arguments in the form of a JSON object.
-runPluginCommand :: Map.Map PluginId [PluginCommand IdeState]
-                 -> LSP.LspFuncs Config
-                 -> IdeState
-                 -> PluginId
-                 -> CommandId
-                 -> J.Value
-                 -> IO (Either ResponseError J.Value,
-                        Maybe (ServerMethod, ApplyWorkspaceEditParams))
-runPluginCommand m lf ide  p@(PluginId p') com@(CommandId com') arg =
-  case Map.lookup p m of
-    Nothing -> return
-      (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing)
-    Just xs -> case List.find ((com ==) . commandId) xs of
-      Nothing -> return (Left $
-        ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'
-                                      <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing)
-      Just (PluginCommand _ _ f) -> case J.fromJSON arg of
-        J.Error err -> return (Left $
-          ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'
-                                       <> ": " <> T.pack err
-                                       <> "\narg = " <> T.pack (show arg)) Nothing, Nothing)
-        J.Success a -> f lf ide a
-
--- -----------------------------------------------------------
-
-mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command
-mkLspCommand plid cn title args' = do
-  pid <- T.pack . show <$> getProcessID
-  let cmdId = mkLspCmdId pid plid cn
-  let args = List <$> args'
-  return $ Command title cmdId args
-
-mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
-mkLspCmdId pid (PluginId plid) (CommandId cid)
-  = pid <> ":" <> plid <> ":" <> cid
-
--- ---------------------------------------------------------------------
-
-hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config
-hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)
-
-hoverRules :: Rules ()
-hoverRules = mempty
-
-hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config
-hoverHandlers hps = PartialHandlers $ \WithMessage{..} x ->
-  return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)}
-
-makeHover :: [(PluginId, HoverProvider IdeState)]
-      -> LSP.LspFuncs Config -> IdeState
-      -> TextDocumentPositionParams
-      -> IO (Either ResponseError (Maybe Hover))
-makeHover hps lf ideState params
-  = do
-      let
-        makeHover(pid,p) = do
-          pluginConfig <- getPluginConfig lf pid
-          if pluginEnabled pluginConfig plcHoverOn
-             then p ideState params
-             else return $ Right Nothing
-      mhs <- mapM makeHover hps
-      -- TODO: We should support ServerCapabilities and declare that
-      -- we don't support hover requests during initialization if we
-      -- don't have any hover providers
-      -- TODO: maybe only have provider give MarkedString and
-      -- work out range here?
-      let hs = catMaybes (rights mhs)
-          r = listToMaybe $ mapMaybe (^. range) hs
-          h = case foldMap (^. contents) hs of
-            HoverContentsMS (List []) -> Nothing
-            hh                        -> Just $ Hover hh r
-      return $ Right h
-
--- ---------------------------------------------------------------------
--- ---------------------------------------------------------------------
-
-symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config
-symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs)
-
-symbolsRules :: Rules ()
-symbolsRules = mempty
-
-symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config
-symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x ->
-  return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)}
-
-makeSymbols :: [(PluginId, SymbolsProvider IdeState)]
-      -> LSP.LspFuncs Config
-      -> IdeState
-      -> DocumentSymbolParams
-      -> IO (Either ResponseError DSResult)
-makeSymbols sps lf ideState params
-  = do
-      let uri' = params ^. textDocument . uri
-          (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf
-          supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport)
-          convertSymbols :: [DocumentSymbol] -> DSResult
-          convertSymbols symbs
-            | supportsHierarchy = DSDocumentSymbols $ List symbs
-            | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs)
-            where
-                go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]
-                go parent ds =
-                  let children' :: [SymbolInformation]
-                      children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))
-                      loc = Location uri' (ds ^. range)
-                      name' = ds ^. name
-                      si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent
-                  in [si] <> children'
-
-          makeSymbols (pid,p) = do
-            pluginConfig <- getPluginConfig lf pid
-            if pluginEnabled pluginConfig plcSymbolsOn
-              then p lf ideState params
-              else return $ Right []
-      mhs <- mapM makeSymbols sps
-      case rights mhs of
-          [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs
-          hs -> return $ Right $ convertSymbols $ concat hs
-
-
--- ---------------------------------------------------------------------
--- ---------------------------------------------------------------------
-
-renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config
-renamePlugins providers = Plugin rules handlers
-  where
-    rules = mempty
-    handlers = PartialHandlers $ \WithMessage{..} x -> return x
-      { LSP.renameHandler = withResponse RspRename (renameWith providers)}
-
-renameWith ::
-  [(PluginId, RenameProvider IdeState)] ->
-  LSP.LspFuncs Config ->
-  IdeState ->
-  RenameParams ->
-  IO (Either ResponseError WorkspaceEdit)
-renameWith providers lspFuncs state params = do
-    let
-        makeAction (pid,p) = do
-          pluginConfig <- getPluginConfig lspFuncs pid
-          if pluginEnabled pluginConfig plcRenameOn
-             then p lspFuncs state params
-             else return $ Right $ WorkspaceEdit Nothing Nothing
-    -- TODO:AZ: we need to consider the right way to combine possible renamers
-    results <- mapM makeAction providers
-    case partitionEithers results of
-        (errors, []) -> return $ Left $ responseError $ T.pack $ show errors
-        (_, edits) -> return $ Right $ mconcat edits
-
--- ---------------------------------------------------------------------
--- ---------------------------------------------------------------------
-
-formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config
-formatterPlugins providers
-    = Plugin formatterRules
-             (formatterHandlers (Map.fromList (("none",noneProvider):providers)))
-
-formatterRules :: Rules ()
-formatterRules = mempty
-
-formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config
-formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x
-    { LSP.documentFormattingHandler
-        = withResponse RspDocumentFormatting (formatting providers)
-    , LSP.documentRangeFormattingHandler
-        = withResponse RspDocumentRangeFormatting (rangeFormatting providers)
-    }
-
--- ---------------------------------------------------------------------
--- ---------------------------------------------------------------------
-
-completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config
-completionsPlugins cs = Plugin completionsRules (completionsHandlers cs)
-
-completionsRules :: Rules ()
-completionsRules = mempty
-
-completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config
-completionsHandlers cps = PartialHandlers $ \WithMessage{..} x ->
-  return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)}
-
-makeCompletions :: [(PluginId, CompletionProvider IdeState)]
-      -> LSP.LspFuncs Config
-      -> IdeState
-      -> CompletionParams
-      -> IO (Either ResponseError CompletionResponseResult)
-makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt)
-  = do
-      mprefix <- getPrefixAtPos lf doc pos
-      _snippets <- WithSnippets . completionSnippetsOn <$> getClientConfig lf
-
-      let
-          combine :: [CompletionResponseResult] -> CompletionResponseResult
-          combine cs = go (Completions $ List []) cs
-              where
-                  go acc [] = acc
-                  go (Completions (List ls)) (Completions (List ls2):rest)
-                      = go (Completions (List (ls <> ls2))) rest
-                  go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest)
-                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest
-                  go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest)
-                      = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest
-                  go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest)
-                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest
-          makeAction (pid,p) = do
-            pluginConfig <- getPluginConfig lf pid
-            if pluginEnabled pluginConfig plcCompletionOn
-               then p lf ideState params
-               else return $ Right $ Completions $ List []
-
-      case mprefix of
-          Nothing -> return $ Right $ Completions $ List []
-          Just _prefix -> do
-            mhs <- mapM makeAction sps
-            case rights mhs of
-                [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs
-                hs -> return $ Right $ combine hs
-
-getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)
-getPrefixAtPos lf uri pos = do
-  mvf <-  LSP.getVirtualFileFunc lf (J.toNormalizedUri uri)
-  case mvf of
-    Just vf -> VFS.getCompletionPrefix pos vf
-    Nothing -> return Nothing
+{-# LANGUAGE DeriveAnyClass #-}++module Development.IDE.Plugin.HLS+    (+      asGhcIdePlugin+    ) where++import           Control.Exception(SomeException, catch)+import           Control.Lens ( (^.) )+import           Control.Monad+import qualified Data.Aeson as J+import           Data.Either+import qualified Data.List                     as List+import qualified Data.Map  as Map+import           Data.Maybe+import qualified Data.Text                     as T+import           Development.IDE.Core.Shake+import           Development.IDE.LSP.Server+import           Development.IDE.Plugin+import           Development.IDE.Plugin.HLS.Formatter+import           GHC.Generics+import           Ide.Plugin.Config+import           Ide.Types as HLS+import qualified Language.Haskell.LSP.Core as LSP+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Types              as J+import qualified Language.Haskell.LSP.Types.Capabilities as C+import           Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)+import qualified Language.Haskell.LSP.VFS                as VFS+import           Text.Regex.TDFA.Text()+import Development.Shake (Rules)+import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)+import Development.IDE.Types.Logger (logInfo)++-- ---------------------------------------------------------------------++-- | Map a set of plugins to the underlying ghcide engine.  Main point is+-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message+-- category ('Notifaction', 'Request' etc).+asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config+asGhcIdePlugin mp =+    mkPlugin rulesPlugins (Just . HLS.pluginRules) <>+    mkPlugin executeCommandPlugins (Just . pluginCommands) <>+    mkPlugin codeActionPlugins     pluginCodeActionProvider <>+    mkPlugin codeLensPlugins       pluginCodeLensProvider <>+    -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider+    mkPlugin hoverPlugins          pluginHoverProvider <>+    mkPlugin symbolsPlugins        pluginSymbolsProvider <>+    mkPlugin formatterPlugins      pluginFormattingProvider <>+    mkPlugin completionsPlugins    pluginCompletionProvider <>+    mkPlugin renamePlugins         pluginRenameProvider+    where+        justs (p, Just x)  = [(p, x)]+        justs (_, Nothing) = []++        ls = Map.toList (ipMap mp)++        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config+        mkPlugin maker selector =+          case concatMap (\(pid, p) -> justs (pid, selector p)) ls of+            -- If there are no plugins that provide a descriptor, use mempty to+            -- create the plugin – otherwise we we end up declaring handlers for+            -- capabilities that there are no plugins for+            [] -> mempty+            xs -> maker xs++-- ---------------------------------------------------------------------++rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config+rulesPlugins rs = Plugin rules mempty+    where+        rules = foldMap snd rs++codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config+codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas)++codeActionRules :: Rules ()+codeActionRules = mempty++codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config+codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x+    { LSP.codeActionHandler+        = withResponse RspCodeAction (makeCodeAction cas)+    }++makeCodeAction :: [(PluginId, CodeActionProvider IdeState)]+      -> LSP.LspFuncs Config -> IdeState+      -> CodeActionParams+      -> IO (Either ResponseError (List CAResult))+makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do+    let caps = LSP.clientCapabilities lf+        unL (List ls) = ls+        makeAction (pid,provider) = do+          pluginConfig <- getPluginConfig lf pid+          if pluginEnabled pluginConfig plcCodeActionsOn+            then provider lf ideState pid docId range context+            else return $ Right (List [])+    r <- mapM makeAction cas+    let actions = filter wasRequested . foldMap unL $ rights r+    res <- send caps actions+    return $ Right res+  where+    wasRequested :: CAResult -> Bool+    wasRequested (CACommand _) = True+    wasRequested (CACodeAction ca)+      | Nothing <- only context = True+      | Just (List allowed) <- only context+      , Just caKind <- ca ^. kind = caKind `elem` allowed+      | otherwise = False++    wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)+    wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd)+    wrapCodeAction caps (CACodeAction action) = do++      let (C.ClientCapabilities _ textDocCaps _ _) = caps+      let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport++      case literalSupport of+        Nothing -> do+            let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]+            cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)+            return $ Just (CACommand cmd)+        Just _ -> return $ Just (CACodeAction action)++    send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)+    send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions++data FallbackCodeActionParams =+  FallbackCodeActionParams+    { fallbackWorkspaceEdit :: Maybe WorkspaceEdit+    , fallbackCommand       :: Maybe Command+    }+  deriving (Generic, J.ToJSON, J.FromJSON)++-- -----------------------------------------------------------++codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config+codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas)++codeLensRules :: Rules ()+codeLensRules = mempty++codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config+codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x+    { LSP.codeLensHandler+        = withResponse RspCodeLens (makeCodeLens cas)+    }++makeCodeLens :: [(PluginId, CodeLensProvider IdeState)]+      -> LSP.LspFuncs Config+      -> IdeState+      -> CodeLensParams+      -> IO (Either ResponseError (List CodeLens))+makeCodeLens cas lf ideState params = do+    logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ+    let+      makeLens (pid, provider) = do+          pluginConfig <- getPluginConfig lf pid+          r <- if pluginEnabled pluginConfig plcCodeLensOn+                 then provider lf ideState pid params+                 else return $ Right (List [])+          return (pid, r)+      breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])+      breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls)+        where+          doOneLeft (pid, Left err) = [(pid,err)]+          doOneLeft (_, Right _) = []++          doOneRight (pid, Right a) = [(pid,a)]+          doOneRight (_, Left _) = []++    r <- mapM makeLens cas+    case breakdown r of+        ([],[]) -> return $ Right $ List []+        (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing+        (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs)++-- -----------------------------------------------------------++executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config+executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)++executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config+executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs)+    }++makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState+makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do+  let+      pluginMap = Map.fromList ecs+      parseCmdId :: T.Text -> Maybe (PluginId, CommandId)+      parseCmdId x = case T.splitOn ":" x of+        [plugin, command] -> Just (PluginId plugin, CommandId command)+        [_, plugin, command] -> Just (PluginId plugin, CommandId command)+        _ -> Nothing++      execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+      execCmd (ExecuteCommandParams cmdId args _) = do+        -- The parameters to the HIE command are always the first element+        let cmdParams :: J.Value+            cmdParams = case args of+             Just (J.List (x:_)) -> x+             _ -> J.Null++        case parseCmdId cmdId of+          -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions+          Just ("hls", "fallbackCodeAction") ->+            case J.fromJSON cmdParams of+              J.Success (FallbackCodeActionParams mEdit mCmd) -> do++                -- Send off the workspace request if it has one+                forM_ mEdit $ \edit -> do+                  let eParams = J.ApplyWorkspaceEditParams edit+                  reqId <- LSP.getNextReqId lf+                  LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams++                case mCmd of+                  -- If we have a command, continue to execute it+                  Just (J.Command _ innerCmdId innerArgs)+                      -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing)+                  Nothing -> return (Right J.Null, Nothing)++              J.Error _str -> return (Right J.Null, Nothing)++          -- Just an ordinary HIE command+          Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams++          -- Couldn't parse the command identifier+          _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing)++  execCmd+++-- -----------------------------------------------------------+wrapUnhandledExceptions ::+    (a -> IO (Either ResponseError J.Value, Maybe b)) ->+       a -> IO (Either ResponseError J.Value, Maybe b)+wrapUnhandledExceptions action input =+    catch (action input) $ \(e::SomeException) -> do+        let resp = ResponseError InternalError (T.pack $ show e) Nothing+        return (Left resp, Nothing)+++-- | Runs a plugin command given a PluginId, CommandId and+-- arguments in the form of a JSON object.+runPluginCommand :: Map.Map PluginId [PluginCommand IdeState]+                 -> LSP.LspFuncs Config+                 -> IdeState+                 -> PluginId+                 -> CommandId+                 -> J.Value+                 -> IO (Either ResponseError J.Value,+                        Maybe (ServerMethod, ApplyWorkspaceEditParams))+runPluginCommand m lf ide  p@(PluginId p') com@(CommandId com') arg =+  case Map.lookup p m of+    Nothing -> return+      (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing)+    Just xs -> case List.find ((com ==) . commandId) xs of+      Nothing -> return (Left $+        ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'+                                      <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing)+      Just (PluginCommand _ _ f) -> case J.fromJSON arg of+        J.Error err -> return (Left $+          ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'+                                       <> ": " <> T.pack err+                                       <> "\narg = " <> T.pack (show arg)) Nothing, Nothing)+        J.Success a -> f lf ide a++-- -----------------------------------------------------------++mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command+mkLspCommand plid cn title args' = do+  pid <- T.pack . show <$> getProcessID+  let cmdId = mkLspCmdId pid plid cn+  let args = List <$> args'+  return $ Command title cmdId args++mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text+mkLspCmdId pid (PluginId plid) (CommandId cid)+  = pid <> ":" <> plid <> ":" <> cid++-- ---------------------------------------------------------------------++hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config+hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)++hoverRules :: Rules ()+hoverRules = mempty++hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config+hoverHandlers hps = PartialHandlers $ \WithMessage{..} x ->+  return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)}++makeHover :: [(PluginId, HoverProvider IdeState)]+      -> LSP.LspFuncs Config -> IdeState+      -> TextDocumentPositionParams+      -> IO (Either ResponseError (Maybe Hover))+makeHover hps lf ideState params+  = do+      let+        makeHover(pid,p) = do+          pluginConfig <- getPluginConfig lf pid+          if pluginEnabled pluginConfig plcHoverOn+             then p ideState params+             else return $ Right Nothing+      mhs <- mapM makeHover hps+      -- TODO: We should support ServerCapabilities and declare that+      -- we don't support hover requests during initialization if we+      -- don't have any hover providers+      -- TODO: maybe only have provider give MarkedString and+      -- work out range here?+      let hs = catMaybes (rights mhs)+          r = listToMaybe $ mapMaybe (^. range) hs+          h = case foldMap (^. contents) hs of+            HoverContentsMS (List []) -> Nothing+            hh                        -> Just $ Hover hh r+      return $ Right h++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config+symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs)++symbolsRules :: Rules ()+symbolsRules = mempty++symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config+symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x ->+  return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)}++makeSymbols :: [(PluginId, SymbolsProvider IdeState)]+      -> LSP.LspFuncs Config+      -> IdeState+      -> DocumentSymbolParams+      -> IO (Either ResponseError DSResult)+makeSymbols sps lf ideState params+  = do+      let uri' = params ^. textDocument . uri+          (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf+          supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport)+          convertSymbols :: [DocumentSymbol] -> DSResult+          convertSymbols symbs+            | supportsHierarchy = DSDocumentSymbols $ List symbs+            | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs)+            where+                go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]+                go parent ds =+                  let children' :: [SymbolInformation]+                      children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))+                      loc = Location uri' (ds ^. range)+                      name' = ds ^. name+                      si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent+                  in [si] <> children'++          makeSymbols (pid,p) = do+            pluginConfig <- getPluginConfig lf pid+            if pluginEnabled pluginConfig plcSymbolsOn+              then p lf ideState params+              else return $ Right []+      mhs <- mapM makeSymbols sps+      case rights mhs of+          [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs+          hs -> return $ Right $ convertSymbols $ concat hs+++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config+renamePlugins providers = Plugin rules handlers+  where+    rules = mempty+    handlers = PartialHandlers $ \WithMessage{..} x -> return x+      { LSP.renameHandler = withResponse RspRename (renameWith providers)}++renameWith ::+  [(PluginId, RenameProvider IdeState)] ->+  LSP.LspFuncs Config ->+  IdeState ->+  RenameParams ->+  IO (Either ResponseError WorkspaceEdit)+renameWith providers lspFuncs state params = do+    let+        makeAction (pid,p) = do+          pluginConfig <- getPluginConfig lspFuncs pid+          if pluginEnabled pluginConfig plcRenameOn+             then p lspFuncs state params+             else return $ Right $ WorkspaceEdit Nothing Nothing+    -- TODO:AZ: we need to consider the right way to combine possible renamers+    results <- mapM makeAction providers+    case partitionEithers results of+        (errors, []) -> return $ Left $ responseError $ T.pack $ show errors+        (_, edits) -> return $ Right $ mconcat edits++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config+formatterPlugins providers+    = Plugin formatterRules+             (formatterHandlers (Map.fromList (("none",noneProvider):providers)))++formatterRules :: Rules ()+formatterRules = mempty++formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config+formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x+    { LSP.documentFormattingHandler+        = withResponse RspDocumentFormatting (formatting providers)+    , LSP.documentRangeFormattingHandler+        = withResponse RspDocumentRangeFormatting (rangeFormatting providers)+    }++-- ---------------------------------------------------------------------+-- ---------------------------------------------------------------------++completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config+completionsPlugins cs = Plugin completionsRules (completionsHandlers cs)++completionsRules :: Rules ()+completionsRules = mempty++completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config+completionsHandlers cps = PartialHandlers $ \WithMessage{..} x ->+  return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)}++makeCompletions :: [(PluginId, CompletionProvider IdeState)]+      -> LSP.LspFuncs Config+      -> IdeState+      -> CompletionParams+      -> IO (Either ResponseError CompletionResponseResult)+makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt)+  = do+      mprefix <- getPrefixAtPos lf doc pos+      _snippets <- WithSnippets . completionSnippetsOn <$> getClientConfig lf++      let+          combine :: [CompletionResponseResult] -> CompletionResponseResult+          combine cs = go (Completions $ List []) cs+              where+                  go acc [] = acc+                  go (Completions (List ls)) (Completions (List ls2):rest)+                      = go (Completions (List (ls <> ls2))) rest+                  go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest)+                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest+                  go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest)+                      = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest+                  go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest)+                      = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest+          makeAction (pid,p) = do+            pluginConfig <- getPluginConfig lf pid+            if pluginEnabled pluginConfig plcCompletionOn+               then p lf ideState params+               else return $ Right $ Completions $ List []++      case mprefix of+          Nothing -> return $ Right $ Completions $ List []+          Just _prefix -> do+            mhs <- mapM makeAction sps+            case rights mhs of+                [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs+                hs -> return $ Right $ combine hs++getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)+getPrefixAtPos lf uri pos = do+  mvf <-  LSP.getVirtualFileFunc lf (J.toNormalizedUri uri)+  case mvf of+    Just vf -> VFS.getCompletionPrefix pos vf+    Nothing -> return Nothing
src/Development/IDE/Plugin/HLS/Formatter.hs view
@@ -1,70 +1,70 @@-
-module Development.IDE.Plugin.HLS.Formatter
-  (
-    formatting
-  , rangeFormatting
-  )
-where
-
-import qualified Data.Map  as Map
-import qualified Data.Text as T
-import           Development.IDE
-import           Ide.PluginUtils
-import           Ide.Types
-import           Ide.Plugin.Config
-import qualified Language.Haskell.LSP.Core as LSP
-import           Language.Haskell.LSP.Types
-import           Text.Regex.TDFA.Text()
-
--- ---------------------------------------------------------------------
-
-formatting :: Map.Map PluginId (FormattingProvider IdeState IO)
-           -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams
-           -> IO (Either ResponseError (List TextEdit))
-formatting providers lf ideState
-    (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress)
-  = doFormatting lf providers ideState FormatText uri params
-
--- ---------------------------------------------------------------------
-
-rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO)
-                -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams
-                -> IO (Either ResponseError (List TextEdit))
-rangeFormatting providers lf ideState
-    (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress)
-  = doFormatting lf providers ideState (FormatRange range) uri params
-
--- ---------------------------------------------------------------------
-
-doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO)
-             -> IdeState -> FormattingType -> Uri -> FormattingOptions
-             -> IO (Either ResponseError (List TextEdit))
-doFormatting lf providers ideState ft uri params = do
-  mc <- LSP.config lf
-  let mf = maybe "none" formattingProvider mc
-  case Map.lookup (PluginId mf) providers of
-      Just provider ->
-        case uriToFilePath uri of
-          Just (toNormalizedFilePath -> fp) -> do
-            (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp
-            case mb_contents of
-              Just contents -> do
-                  logDebug (ideLogger ideState) $ T.pack $
-                      "Formatter.doFormatting: contents=" ++ show contents -- AZ
-                  provider lf ideState ft contents fp params
-              Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri
-          Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri
-      Nothing -> return $ Left $ responseError $ mconcat
-        [ "Formatter plugin: no formatter found for:["
-        , mf
-        , "]"
-        , if mf == "brittany"
-          then T.unlines
-            [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany."
-            , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file."
-            , "The 'haskell-language-server.cabal' file already has this flag enabled by default."
-            , "For more information see: https://github.com/haskell/haskell-language-server/issues/269"
-            ]
-          else ""
-        ]
-
++module Development.IDE.Plugin.HLS.Formatter+  (+    formatting+  , rangeFormatting+  )+where++import qualified Data.Map  as Map+import qualified Data.Text as T+import           Development.IDE+import           Ide.PluginUtils+import           Ide.Types+import           Ide.Plugin.Config+import qualified Language.Haskell.LSP.Core as LSP+import           Language.Haskell.LSP.Types+import           Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++formatting :: Map.Map PluginId (FormattingProvider IdeState IO)+           -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams+           -> IO (Either ResponseError (List TextEdit))+formatting providers lf ideState+    (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress)+  = doFormatting lf providers ideState FormatText uri params++-- ---------------------------------------------------------------------++rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO)+                -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams+                -> IO (Either ResponseError (List TextEdit))+rangeFormatting providers lf ideState+    (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress)+  = doFormatting lf providers ideState (FormatRange range) uri params++-- ---------------------------------------------------------------------++doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO)+             -> IdeState -> FormattingType -> Uri -> FormattingOptions+             -> IO (Either ResponseError (List TextEdit))+doFormatting lf providers ideState ft uri params = do+  mc <- LSP.config lf+  let mf = maybe "none" formattingProvider mc+  case Map.lookup (PluginId mf) providers of+      Just provider ->+        case uriToFilePath uri of+          Just (toNormalizedFilePath -> fp) -> do+            (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp+            case mb_contents of+              Just contents -> do+                  logDebug (ideLogger ideState) $ T.pack $+                      "Formatter.doFormatting: contents=" ++ show contents -- AZ+                  provider lf ideState ft contents fp params+              Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri+          Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri+      Nothing -> return $ Left $ responseError $ mconcat+        [ "Formatter plugin: no formatter found for:["+        , mf+        , "]"+        , if mf == "brittany"+          then T.unlines+            [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany."+            , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file."+            , "The 'haskell-language-server.cabal' file already has this flag enabled by default."+            , "For more information see: https://github.com/haskell/haskell-language-server/issues/269"+            ]+          else ""+        ]+
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -1,69 +1,69 @@-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Exposes the ghcide features as an HLS plugin
-module Development.IDE.Plugin.HLS.GhcIde
-  (
-    descriptor
-  ) where
-
-import Data.Aeson
-import Development.IDE
-import Development.IDE.Plugin as Ghcide
-import Development.IDE.Plugin.Completions as Completions
-import Development.IDE.Plugin.CodeAction as CodeAction
-import Development.IDE.LSP.HoverDefinition
-import Development.IDE.LSP.Outline
-import Ide.PluginUtils
-import Ide.Types
-import Language.Haskell.LSP.Types
-import Text.Regex.TDFA.Text()
-
--- ---------------------------------------------------------------------
-
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId)
-  { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]
-  , pluginCodeActionProvider = Just codeAction'
-  , pluginCodeLensProvider   = Just codeLens'
-  , pluginHoverProvider      = Just hover'
-  , pluginSymbolsProvider    = Just symbolsProvider
-  , pluginCompletionProvider = Just getCompletionsLSP
-  , pluginRules              = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin
-  }
-
--- ---------------------------------------------------------------------
-
-hover' :: HoverProvider IdeState
-hover' ideState params = do
-    logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ
-    hover ideState params
-
--- ---------------------------------------------------------------------
-
-commandAddSignature :: CommandFunction IdeState WorkspaceEdit
-commandAddSignature lf ide params
-    = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)
-
--- ---------------------------------------------------------------------
-
-codeAction' :: CodeActionProvider IdeState
-codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context
-
--- ---------------------------------------------------------------------
-
-codeLens' :: CodeLensProvider IdeState
-codeLens' lf ide _ params = codeLens lf ide params
-
--- ---------------------------------------------------------------------
-
-symbolsProvider :: SymbolsProvider IdeState
-symbolsProvider ls ide params = do
-    ds <- moduleOutline ls ide params
-    case ds of
-        Right (DSDocumentSymbols (List ls)) -> return $ Right ls
-        Right (DSSymbolInformation (List _si)) ->
-            return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated"
-        Left err -> return $ Left err
-
--- ---------------------------------------------------------------------
+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Exposes the ghcide features as an HLS plugin+module Development.IDE.Plugin.HLS.GhcIde+  (+    descriptor+  ) where++import Data.Aeson+import Development.IDE+import Development.IDE.Plugin as Ghcide+import Development.IDE.Plugin.Completions as Completions+import Development.IDE.Plugin.CodeAction as CodeAction+import Development.IDE.LSP.HoverDefinition+import Development.IDE.LSP.Outline+import Ide.PluginUtils+import Ide.Types+import Language.Haskell.LSP.Types+import Text.Regex.TDFA.Text()++-- ---------------------------------------------------------------------++descriptor :: PluginId -> PluginDescriptor IdeState+descriptor plId = (defaultPluginDescriptor plId)+  { pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]+  , pluginCodeActionProvider = Just codeAction'+  , pluginCodeLensProvider   = Just codeLens'+  , pluginHoverProvider      = Just hover'+  , pluginSymbolsProvider    = Just symbolsProvider+  , pluginCompletionProvider = Just getCompletionsLSP+  , pluginRules              = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin+  }++-- ---------------------------------------------------------------------++hover' :: HoverProvider IdeState+hover' ideState params = do+    logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ+    hover ideState params++-- ---------------------------------------------------------------------++commandAddSignature :: CommandFunction IdeState WorkspaceEdit+commandAddSignature lf ide params+    = commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)++-- ---------------------------------------------------------------------++codeAction' :: CodeActionProvider IdeState+codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context++-- ---------------------------------------------------------------------++codeLens' :: CodeLensProvider IdeState+codeLens' lf ide _ params = codeLens lf ide params++-- ---------------------------------------------------------------------++symbolsProvider :: SymbolsProvider IdeState+symbolsProvider ls ide params = do+    ds <- moduleOutline ls ide params+    case ds of+        Right (DSDocumentSymbols (List ls)) -> return $ Right ls+        Right (DSSymbolInformation (List _si)) ->+            return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated"+        Left err -> return $ Left err++-- ---------------------------------------------------------------------
src/Development/IDE/Plugin/Test.hs view
@@ -1,106 +1,106 @@-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
--- | A plugin that adds custom messages for use in tests
-module Development.IDE.Plugin.Test
-  ( TestRequest(..)
-  , WaitForIdeRuleResult(..)
-  , plugin
-  ) where
-
-import Control.Monad.STM
-import Data.Aeson
-import Data.Aeson.Types
-import Data.CaseInsensitive (CI, original)
-import Development.IDE.Core.Service
-import Development.IDE.Core.Shake
-import Development.IDE.GHC.Compat
-import Development.IDE.GHC.Util (HscEnvEq(hscEnv))
-import Development.IDE.LSP.Server
-import Development.IDE.Plugin
-import Development.IDE.Types.Action
-import GHC.Generics (Generic)
-import GhcPlugins (HscEnv(hsc_dflags))
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import System.Time.Extra
-import Development.IDE.Core.RuleTypes
-import Control.Monad
-import Development.Shake (Action)
-import Data.Maybe (isJust)
-import Data.Bifunctor
-import Data.Text (pack, Text)
-import Data.String
-import Development.IDE.Types.Location (fromUri)
-
-data TestRequest
-    = BlockSeconds Seconds           -- ^ :: Null
-    | GetInterfaceFilesDir FilePath  -- ^ :: String
-    | GetShakeSessionQueueCount      -- ^ :: Number
-    | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
-    | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult
-    deriving Generic
-    deriving anyclass (FromJSON, ToJSON)
-
-newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}
-    deriving newtype (FromJSON, ToJSON)
-
-plugin :: Plugin c
-plugin = Plugin {
-    pluginRules = return (),
-    pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {
-        customRequestHandler = withResponse RspCustomServer requestHandler'
-    }
-}
-  where
-      requestHandler' lsp ide req
-        | Just customReq <- parseMaybe parseJSON req
-        = requestHandler lsp ide customReq
-        | otherwise
-        = return $ Left
-        $ ResponseError InvalidRequest "Cannot parse request" Nothing
-
-requestHandler :: LspFuncs c
-                -> IdeState
-                -> TestRequest
-                -> IO (Either ResponseError Value)
-requestHandler lsp _ (BlockSeconds secs) = do
-    sendFunc lsp $ NotCustomServer $
-        NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $
-        toJSON secs
-    sleep secs
-    return (Right Null)
-requestHandler _ s (GetInterfaceFilesDir fp) = do
-    let nfp = toNormalizedFilePath fp
-    sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
-    let hiPath = hiDir $ hsc_dflags $ hscEnv sess
-    return $ Right (toJSON hiPath)
-requestHandler _ s GetShakeSessionQueueCount = do
-    n <- atomically $ countQueue $ actionQueue $ shakeExtras s
-    return $ Right (toJSON n)
-requestHandler _ s WaitForShakeQueue = do
-    atomically $ do
-        n <- countQueue $ actionQueue $ shakeExtras s
-        when (n>0) retry
-    return $ Right Null
-requestHandler _ s (WaitForIdeRule k file) = do
-    let nfp = fromUri $ toNormalizedUri file
-    success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
-    let res = WaitForIdeRuleResult <$> success
-    return $ bimap mkResponseError toJSON res
-
-mkResponseError :: Text -> ResponseError
-mkResponseError msg = ResponseError InvalidRequest msg Nothing
-
-parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
-parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp
-parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp
-parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp
-parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp
-parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp
-parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp
-parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp
-parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp
-parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp
-parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp
-parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+-- | A plugin that adds custom messages for use in tests+module Development.IDE.Plugin.Test+  ( TestRequest(..)+  , WaitForIdeRuleResult(..)+  , plugin+  ) where++import Control.Monad.STM+import Data.Aeson+import Data.Aeson.Types+import Data.CaseInsensitive (CI, original)+import Development.IDE.Core.Service+import Development.IDE.Core.Shake+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util (HscEnvEq(hscEnv))+import Development.IDE.LSP.Server+import Development.IDE.Plugin+import Development.IDE.Types.Action+import GHC.Generics (Generic)+import GhcPlugins (HscEnv(hsc_dflags))+import Language.Haskell.LSP.Core+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import System.Time.Extra+import Development.IDE.Core.RuleTypes+import Control.Monad+import Development.Shake (Action)+import Data.Maybe (isJust)+import Data.Bifunctor+import Data.Text (pack, Text)+import Data.String+import Development.IDE.Types.Location (fromUri)++data TestRequest+    = BlockSeconds Seconds           -- ^ :: Null+    | GetInterfaceFilesDir FilePath  -- ^ :: String+    | GetShakeSessionQueueCount      -- ^ :: Number+    | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null+    | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult+    deriving Generic+    deriving anyclass (FromJSON, ToJSON)++newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}+    deriving newtype (FromJSON, ToJSON)++plugin :: Plugin c+plugin = Plugin {+    pluginRules = return (),+    pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {+        customRequestHandler = withResponse RspCustomServer requestHandler'+    }+}+  where+      requestHandler' lsp ide req+        | Just customReq <- parseMaybe parseJSON req+        = requestHandler lsp ide customReq+        | otherwise+        = return $ Left+        $ ResponseError InvalidRequest "Cannot parse request" Nothing++requestHandler :: LspFuncs c+                -> IdeState+                -> TestRequest+                -> IO (Either ResponseError Value)+requestHandler lsp _ (BlockSeconds secs) = do+    sendFunc lsp $ NotCustomServer $+        NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $+        toJSON secs+    sleep secs+    return (Right Null)+requestHandler _ s (GetInterfaceFilesDir fp) = do+    let nfp = toNormalizedFilePath fp+    sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp+    let hiPath = hiDir $ hsc_dflags $ hscEnv sess+    return $ Right (toJSON hiPath)+requestHandler _ s GetShakeSessionQueueCount = do+    n <- atomically $ countQueue $ actionQueue $ shakeExtras s+    return $ Right (toJSON n)+requestHandler _ s WaitForShakeQueue = do+    atomically $ do+        n <- countQueue $ actionQueue $ shakeExtras s+        when (n>0) retry+    return $ Right Null+requestHandler _ s (WaitForIdeRule k file) = do+    let nfp = fromUri $ toNormalizedUri file+    success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp+    let res = WaitForIdeRuleResult <$> success+    return $ bimap mkResponseError toJSON res++mkResponseError :: Text -> ResponseError+mkResponseError msg = ResponseError InvalidRequest msg Nothing++parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)+parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp+parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp+parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp+parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp+parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp+parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp+parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp+parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp+parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp+parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp+parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
src/Development/IDE/Spans/AtPoint.hs view
@@ -1,203 +1,203 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- | Gives information about symbols at a given point in DAML files.
--- These are all pure functions that should execute quickly.
-module Development.IDE.Spans.AtPoint (
-    atPoint
-  , gotoDefinition
-  , gotoTypeDefinition
-  , documentHighlight
-  , pointCommand
-  ) where
-
-import           Development.IDE.GHC.Error
-import Development.IDE.GHC.Orphans()
-import Development.IDE.Types.Location
-import           Language.Haskell.LSP.Types
-
--- DAML compiler and infrastructure
-import Development.IDE.GHC.Compat
-import Development.IDE.Types.Options
-import Development.IDE.Spans.Common
-import Development.IDE.Core.RuleTypes
-
--- GHC API imports
-import FastString
-import Name
-import Outputable hiding ((<>))
-import SrcLoc
-import TyCoRep
-import TyCon
-import qualified Var
-import NameEnv
-
-import Control.Applicative
-import Control.Monad.Extra
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Class
-import Control.Monad.IO.Class
-import           Data.Maybe
-import           Data.List
-import qualified Data.Text as T
-import qualified Data.Map as M
-
-import Data.Either
-import Data.List.Extra (dropEnd1)
-
-documentHighlight
-  :: Monad m
-  => HieASTs Type
-  -> RefMap
-  -> Position
-  -> MaybeT m [DocumentHighlight]
-documentHighlight hf rf pos = MaybeT $ pure (Just highlights)
-  where
-    ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)
-    highlights = do
-      n <- ns
-      ref <- maybe [] id (M.lookup (Right n) rf)
-      pure $ makeHighlight ref
-    makeHighlight (sp,dets) =
-      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
-    highlightType s =
-      if any (isJust . getScopeFromContext) s
-        then HkWrite
-        else HkRead
-
-gotoTypeDefinition
-  :: MonadIO m
-  => (Module -> MaybeT m (HieFile, FilePath))
-  -> IdeOptions
-  -> HieASTs Type
-  -> Position
-  -> MaybeT m [Location]
-gotoTypeDefinition getHieFile ideOpts srcSpans pos
-  = lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans
-
--- | Locate the definition of the name at a given position.
-gotoDefinition
-  :: MonadIO m
-  => (Module -> MaybeT m (HieFile, FilePath))
-  -> IdeOptions
-  -> M.Map ModuleName NormalizedFilePath
-  -> HieASTs Type
-  -> Position
-  -> MaybeT m Location
-gotoDefinition getHieFile ideOpts imports srcSpans pos
-  = MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts imports pos srcSpans
-
--- | Synopsis for the name at a given position.
-atPoint
-  :: IdeOptions
-  -> HieASTs Type
-  -> DocAndKindMap
-  -> Position
-  -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{} hf (DKMap dm km) 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
-          | otherwise = map wrapHaskell prettyTypes
-
-        range = realSrcSpanToRange $ nodeSpan ast
-
-        wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
-        info = nodeInfo ast
-        names = M.assocs $ nodeIdentifiers info
-        types = nodeType info
-
-        prettyNames :: [T.Text]
-        prettyNames = map prettyName names
-        prettyName (Right n, dets) = T.unlines $
-          wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind))
-          : definedAt n
-          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
-                      ]
-          where maybeKind = safeTyThingType =<< lookupNameEnv km n
-        prettyName (Left m,_) = showName m
-
-        prettyTypes = map (("_ :: "<>) . prettyType) types
-        prettyType t = showName t
-
-        definedAt name =
-          -- do not show "at <no location info>" and similar messages
-          -- see the code of 'pprNameDefnLoc' for more information
-          case nameSrcLoc name of
-            UnhelpfulLoc {} | isInternalName name || isSystemName name -> []
-            _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"]
-
-typeLocationsAtPoint
-  :: forall m
-   . MonadIO m
-  => (Module -> MaybeT m (HieFile, FilePath))
-  -> IdeOptions
-  -> Position
-  -> HieASTs Type
-  -> m [Location]
-typeLocationsAtPoint getHieFile _ideOptions pos ast =
-  let ts = concat $ pointCommand ast pos (nodeType . nodeInfo)
-      ns = flip mapMaybe ts $ \case
-        TyConApp tc _ -> Just $ tyConName tc
-        TyVarTy n -> Just $ Var.varName n
-        _ -> Nothing
-    in mapMaybeM (nameToLocation getHieFile) ns
-
-locationsAtPoint
-  :: forall m
-   . MonadIO m
-  => (Module -> MaybeT m (HieFile, FilePath))
-  -> IdeOptions
-  -> M.Map ModuleName NormalizedFilePath
-  -> Position
-  -> HieASTs Type
-  -> m [Location]
-locationsAtPoint getHieFile _ideOptions imports pos ast =
-  let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo)
-      zeroPos = Position 0 0
-      zeroRange = Range zeroPos zeroPos
-      modToLocation m = fmap (\fs -> Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports
-    in mapMaybeM (either (pure . modToLocation) $ nameToLocation getHieFile) ns
-
--- | Given a 'Name' attempt to find the location where it is defined.
-nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location)
-nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $
-  case nameSrcSpan name of
-    sp@(RealSrcSpan _) -> pure $ Just sp
-    sp@(UnhelpfulSpan _) -> runMaybeT $ do
-      guard (sp /= wiredInSrcSpan)
-      -- This case usually arises when the definition is in an external package.
-      -- In this case the interface files contain garbage source spans
-      -- so we instead read the .hie files to get useful source spans.
-      mod <- MaybeT $ return $ nameModule_maybe name
-      (hieFile, srcPath) <- getHieFile mod
-      avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
-      -- The location will point to the source file used during compilation.
-      -- This file might no longer exists and even if it does the path will be relative
-      -- to the compilation directory which we don’t know.
-      let span = setFileName srcPath $ fst avail
-      pure span
-  where
-    -- We ignore uniques and source spans and only compare the name and the module.
-    eqName :: Name -> Name -> Bool
-    eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'
-    setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
-    setFileName _ span@(UnhelpfulSpan _) = span
-
-pointCommand :: HieASTs Type -> Position -> (HieAST Type -> a) -> [a]
-pointCommand hf pos k =
-    catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
-      case selectSmallestContaining (sp fs) ast of
-        Nothing -> Nothing
-        Just ast' -> Just $ k ast'
- where
-   sloc fs = mkRealSrcLoc fs (line+1) (cha+1)
-   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
-   line = _line pos
-   cha = _character pos
-
-
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- | Gives information about symbols at a given point in DAML files.+-- These are all pure functions that should execute quickly.+module Development.IDE.Spans.AtPoint (+    atPoint+  , gotoDefinition+  , gotoTypeDefinition+  , documentHighlight+  , pointCommand+  ) where++import           Development.IDE.GHC.Error+import Development.IDE.GHC.Orphans()+import Development.IDE.Types.Location+import           Language.Haskell.LSP.Types++-- DAML compiler and infrastructure+import Development.IDE.GHC.Compat+import Development.IDE.Types.Options+import Development.IDE.Spans.Common+import Development.IDE.Core.RuleTypes++-- GHC API imports+import FastString+import Name+import Outputable hiding ((<>))+import SrcLoc+import TyCoRep+import TyCon+import qualified Var+import NameEnv++import Control.Applicative+import Control.Monad.Extra+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import           Data.Maybe+import           Data.List+import qualified Data.Text as T+import qualified Data.Map as M++import Data.Either+import Data.List.Extra (dropEnd1)++documentHighlight+  :: Monad m+  => HieASTs Type+  -> RefMap+  -> Position+  -> MaybeT m [DocumentHighlight]+documentHighlight hf rf pos = MaybeT $ pure (Just highlights)+  where+    ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)+    highlights = do+      n <- ns+      ref <- maybe [] id (M.lookup (Right n) rf)+      pure $ makeHighlight ref+    makeHighlight (sp,dets) =+      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)+    highlightType s =+      if any (isJust . getScopeFromContext) s+        then HkWrite+        else HkRead++gotoTypeDefinition+  :: MonadIO m+  => (Module -> MaybeT m (HieFile, FilePath))+  -> IdeOptions+  -> HieASTs Type+  -> Position+  -> MaybeT m [Location]+gotoTypeDefinition getHieFile ideOpts srcSpans pos+  = lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans++-- | Locate the definition of the name at a given position.+gotoDefinition+  :: MonadIO m+  => (Module -> MaybeT m (HieFile, FilePath))+  -> IdeOptions+  -> M.Map ModuleName NormalizedFilePath+  -> HieASTs Type+  -> Position+  -> MaybeT m Location+gotoDefinition getHieFile ideOpts imports srcSpans pos+  = MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts imports pos srcSpans++-- | Synopsis for the name at a given position.+atPoint+  :: IdeOptions+  -> HieASTs Type+  -> DocAndKindMap+  -> Position+  -> Maybe (Maybe Range, [T.Text])+atPoint IdeOptions{} hf (DKMap dm km) 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+          | otherwise = map wrapHaskell prettyTypes++        range = realSrcSpanToRange $ nodeSpan ast++        wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"+        info = nodeInfo ast+        names = M.assocs $ nodeIdentifiers info+        types = nodeType info++        prettyNames :: [T.Text]+        prettyNames = map prettyName names+        prettyName (Right n, dets) = T.unlines $+          wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind))+          : definedAt n+          ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n+                      ]+          where maybeKind = safeTyThingType =<< lookupNameEnv km n+        prettyName (Left m,_) = showName m++        prettyTypes = map (("_ :: "<>) . prettyType) types+        prettyType t = showName t++        definedAt name =+          -- do not show "at <no location info>" and similar messages+          -- see the code of 'pprNameDefnLoc' for more information+          case nameSrcLoc name of+            UnhelpfulLoc {} | isInternalName name || isSystemName name -> []+            _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"]++typeLocationsAtPoint+  :: forall m+   . MonadIO m+  => (Module -> MaybeT m (HieFile, FilePath))+  -> IdeOptions+  -> Position+  -> HieASTs Type+  -> m [Location]+typeLocationsAtPoint getHieFile _ideOptions pos ast =+  let ts = concat $ pointCommand ast pos (nodeType . nodeInfo)+      ns = flip mapMaybe ts $ \case+        TyConApp tc _ -> Just $ tyConName tc+        TyVarTy n -> Just $ Var.varName n+        _ -> Nothing+    in mapMaybeM (nameToLocation getHieFile) ns++locationsAtPoint+  :: forall m+   . MonadIO m+  => (Module -> MaybeT m (HieFile, FilePath))+  -> IdeOptions+  -> M.Map ModuleName NormalizedFilePath+  -> Position+  -> HieASTs Type+  -> m [Location]+locationsAtPoint getHieFile _ideOptions imports pos ast =+  let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo)+      zeroPos = Position 0 0+      zeroRange = Range zeroPos zeroPos+      modToLocation m = fmap (\fs -> Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports+    in mapMaybeM (either (pure . modToLocation) $ nameToLocation getHieFile) ns++-- | Given a 'Name' attempt to find the location where it is defined.+nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location)+nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $+  case nameSrcSpan name of+    sp@(RealSrcSpan _) -> pure $ Just sp+    sp@(UnhelpfulSpan _) -> runMaybeT $ do+      guard (sp /= wiredInSrcSpan)+      -- This case usually arises when the definition is in an external package.+      -- In this case the interface files contain garbage source spans+      -- so we instead read the .hie files to get useful source spans.+      mod <- MaybeT $ return $ nameModule_maybe name+      (hieFile, srcPath) <- getHieFile mod+      avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile+      -- The location will point to the source file used during compilation.+      -- This file might no longer exists and even if it does the path will be relative+      -- to the compilation directory which we don’t know.+      let span = setFileName srcPath $ fst avail+      pure span+  where+    -- We ignore uniques and source spans and only compare the name and the module.+    eqName :: Name -> Name -> Bool+    eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'+    setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })+    setFileName _ span@(UnhelpfulSpan _) = span++pointCommand :: HieASTs Type -> Position -> (HieAST Type -> a) -> [a]+pointCommand hf pos k =+    catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->+      case selectSmallestContaining (sp fs) ast of+        Nothing -> Nothing+        Just ast' -> Just $ k ast'+ where+   sloc fs = mkRealSrcLoc fs (line+1) (cha+1)+   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)+   line = _line pos+   cha = _character pos++
src/Development/IDE/Spans/Common.hs view
@@ -1,189 +1,189 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveAnyClass #-}
-#include "ghc-api-version.h"
-
-module Development.IDE.Spans.Common (
-  showGhc
-, showName
-, showNameWithoutUniques
-, safeTyThingId
-, safeTyThingType
-, SpanDoc(..)
-, SpanDocUris(..)
-, emptySpanDoc
-, spanDocToMarkdown
-, spanDocToMarkdownForTest
-, DocMap
-, KindMap
-) where
-
-import Data.Maybe
-import qualified Data.Text as T
-import Data.List.Extra
-import Control.DeepSeq
-import GHC.Generics
-
-import GHC
-import Outputable hiding ((<>))
-import ConLike
-import DataCon
-import Var
-import NameEnv
-
-import qualified Documentation.Haddock.Parser as H
-import qualified Documentation.Haddock.Types as H
-import Development.IDE.GHC.Compat
-import Development.IDE.GHC.Orphans ()
-
-type DocMap = NameEnv SpanDoc
-type KindMap = NameEnv TyThing
-
-showGhc :: Outputable a => a -> String
-showGhc = showPpr unsafeGlobalDynFlags
-
-showName :: Outputable a => a -> T.Text
-showName = T.pack . prettyprint
-  where
-    prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
-    style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
-
-showNameWithoutUniques :: Outputable a => a -> T.Text
-showNameWithoutUniques = T.pack . prettyprint
-  where
-    dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques
-    prettyprint x = renderWithStyle dyn (ppr x) style
-    style = mkUserStyle dyn neverQualify AllTheWay
-
--- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
-safeTyThingType :: TyThing -> Maybe Type
-safeTyThingType thing
-  | Just i <- safeTyThingId thing = Just (varType i)
-safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)
-safeTyThingType _                 = Nothing
-
-safeTyThingId :: TyThing -> Maybe Id
-safeTyThingId (AnId i)                    = Just i
-safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
-safeTyThingId _                           = Nothing
-
--- Possible documentation for an element in the code
-data SpanDoc
-  = SpanDocString HsDocString SpanDocUris
-  | SpanDocText   [T.Text] SpanDocUris
-  deriving stock (Eq, Show, Generic)
-  deriving anyclass NFData
-
-data SpanDocUris =
-  SpanDocUris
-  { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page
-  , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page
-  } deriving stock (Eq, Show, Generic)
-    deriving anyclass NFData
-
-emptySpanDoc :: SpanDoc
-emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
-
-spanDocToMarkdown :: SpanDoc -> [T.Text]
-spanDocToMarkdown (SpanDocString docs uris)
-  = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
-    <> ["\n"] <> spanDocUrisToMarkdown uris
-  -- Append the extra newlines since this is markdown --- to get a visible newline,
-  -- you need to have two newlines
-spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris
-
-spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]
-spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes
-  [ linkify "Documentation" <$> mdoc
-  , linkify "Source" <$> msrc
-  ]
-  where linkify title uri = "[" <> title <> "](" <> uri <> ")"
-
-spanDocToMarkdownForTest :: String -> String
-spanDocToMarkdownForTest
-  = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
-
--- Simple (and a bit hacky) conversion from Haddock markup to Markdown
-haddockToMarkdown
-  :: H.DocH String String -> String
-
-haddockToMarkdown H.DocEmpty
-  = ""
-haddockToMarkdown (H.DocAppend d1 d2)
-  = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
-haddockToMarkdown (H.DocString s)
-  = escapeBackticks s
-haddockToMarkdown (H.DocParagraph p)
-  = "\n\n" ++ haddockToMarkdown p
-haddockToMarkdown (H.DocIdentifier i)
-  = "`" ++ i ++ "`"
-haddockToMarkdown (H.DocIdentifierUnchecked i)
-  = "`" ++ i ++ "`"
-haddockToMarkdown (H.DocModule i)
-  = "`" ++ escapeBackticks i ++ "`"
-haddockToMarkdown (H.DocWarning w)
-  = haddockToMarkdown w
-haddockToMarkdown (H.DocEmphasis d)
-  = "*" ++ haddockToMarkdown d ++ "*"
-haddockToMarkdown (H.DocBold d)
-  = "**" ++ haddockToMarkdown d ++ "**"
-haddockToMarkdown (H.DocMonospaced d)
-  = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`"
-haddockToMarkdown (H.DocCodeBlock d)
-  = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"
-haddockToMarkdown (H.DocExamples es)
-  = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"
-  where
-    exampleToMarkdown (H.Example expr result)
-      = ">>> " ++ expr ++ "\n" ++ unlines result
-haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
-  = "<" ++ url ++ ">"
-haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
-  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
-haddockToMarkdown (H.DocPic (H.Picture url Nothing))
-  = "![](" ++ url ++ ")"
-haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
-  = "![" ++ label ++ "](" ++ url ++ ")"
-haddockToMarkdown (H.DocAName aname)
-  = "[" ++ escapeBackticks aname ++ "]:"
-haddockToMarkdown (H.DocHeader (H.Header level title))
-  = replicate level '#' ++ " " ++ haddockToMarkdown title
-
-haddockToMarkdown (H.DocUnorderedList things)
-  = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
-haddockToMarkdown (H.DocOrderedList things)
-  = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
-haddockToMarkdown (H.DocDefList things)
-  = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
-
--- we cannot render math by default
-haddockToMarkdown (H.DocMathInline _)
-  = "*cannot render inline math formula*"
-haddockToMarkdown (H.DocMathDisplay _)
-  = "\n\n*cannot render display math formula*\n\n"
-
--- TODO: render tables
-haddockToMarkdown (H.DocTable _t)
-  = "\n\n*tables are not yet supported*\n\n"
-
--- things I don't really know how to handle
-haddockToMarkdown (H.DocProperty _)
-  = ""  -- don't really know what to do
-
-escapeBackticks :: String -> String
-escapeBackticks "" = ""
-escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss
-escapeBackticks (s  :ss) = s:escapeBackticks ss
-
-removeUnescapedBackticks :: String -> String
-removeUnescapedBackticks = \case
-  '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss
-  '`' : ss -> removeUnescapedBackticks ss
-  "" -> ""
-  s : ss -> s : removeUnescapedBackticks ss
-
-splitForList :: String -> String
-splitForList s
-  = case lines s of
-      [] -> ""
-      (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest
+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+#include "ghc-api-version.h"++module Development.IDE.Spans.Common (+  showGhc+, showName+, showNameWithoutUniques+, safeTyThingId+, safeTyThingType+, SpanDoc(..)+, SpanDocUris(..)+, emptySpanDoc+, spanDocToMarkdown+, spanDocToMarkdownForTest+, DocMap+, KindMap+) where++import Data.Maybe+import qualified Data.Text as T+import Data.List.Extra+import Control.DeepSeq+import GHC.Generics++import GHC+import Outputable hiding ((<>))+import ConLike+import DataCon+import Var+import NameEnv++import qualified Documentation.Haddock.Parser as H+import qualified Documentation.Haddock.Types as H+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Orphans ()++type DocMap = NameEnv SpanDoc+type KindMap = NameEnv TyThing++showGhc :: Outputable a => a -> String+showGhc = showPpr unsafeGlobalDynFlags++showName :: Outputable a => a -> T.Text+showName = T.pack . prettyprint+  where+    prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style+    style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay++showNameWithoutUniques :: Outputable a => a -> T.Text+showNameWithoutUniques = T.pack . prettyprint+  where+    dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques+    prettyprint x = renderWithStyle dyn (ppr x) style+    style = mkUserStyle dyn neverQualify AllTheWay++-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs+safeTyThingType :: TyThing -> Maybe Type+safeTyThingType thing+  | Just i <- safeTyThingId thing = Just (varType i)+safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)+safeTyThingType _                 = Nothing++safeTyThingId :: TyThing -> Maybe Id+safeTyThingId (AnId i)                    = Just i+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc+safeTyThingId _                           = Nothing++-- Possible documentation for an element in the code+data SpanDoc+  = SpanDocString HsDocString SpanDocUris+  | SpanDocText   [T.Text] SpanDocUris+  deriving stock (Eq, Show, Generic)+  deriving anyclass NFData++data SpanDocUris =+  SpanDocUris+  { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page+  , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page+  } deriving stock (Eq, Show, Generic)+    deriving anyclass NFData++emptySpanDoc :: SpanDoc+emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)++spanDocToMarkdown :: SpanDoc -> [T.Text]+spanDocToMarkdown (SpanDocString docs uris)+  = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]+    <> ["\n"] <> spanDocUrisToMarkdown uris+  -- Append the extra newlines since this is markdown --- to get a visible newline,+  -- you need to have two newlines+spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris++spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]+spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes+  [ linkify "Documentation" <$> mdoc+  , linkify "Source" <$> msrc+  ]+  where linkify title uri = "[" <> title <> "](" <> uri <> ")"++spanDocToMarkdownForTest :: String -> String+spanDocToMarkdownForTest+  = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing++-- Simple (and a bit hacky) conversion from Haddock markup to Markdown+haddockToMarkdown+  :: H.DocH String String -> String++haddockToMarkdown H.DocEmpty+  = ""+haddockToMarkdown (H.DocAppend d1 d2)+  = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2+haddockToMarkdown (H.DocString s)+  = escapeBackticks s+haddockToMarkdown (H.DocParagraph p)+  = "\n\n" ++ haddockToMarkdown p+haddockToMarkdown (H.DocIdentifier i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocIdentifierUnchecked i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocModule i)+  = "`" ++ escapeBackticks i ++ "`"+haddockToMarkdown (H.DocWarning w)+  = haddockToMarkdown w+haddockToMarkdown (H.DocEmphasis d)+  = "*" ++ haddockToMarkdown d ++ "*"+haddockToMarkdown (H.DocBold d)+  = "**" ++ haddockToMarkdown d ++ "**"+haddockToMarkdown (H.DocMonospaced d)+  = "`" ++ removeUnescapedBackticks (haddockToMarkdown d) ++ "`"+haddockToMarkdown (H.DocCodeBlock d)+  = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"+haddockToMarkdown (H.DocExamples es)+  = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"+  where+    exampleToMarkdown (H.Example expr result)+      = ">>> " ++ expr ++ "\n" ++ unlines result+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))+  = "<" ++ url ++ ">"+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))+  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"+haddockToMarkdown (H.DocPic (H.Picture url Nothing))+  = "![](" ++ url ++ ")"+haddockToMarkdown (H.DocPic (H.Picture url (Just label)))+  = "![" ++ label ++ "](" ++ url ++ ")"+haddockToMarkdown (H.DocAName aname)+  = "[" ++ escapeBackticks aname ++ "]:"+haddockToMarkdown (H.DocHeader (H.Header level title))+  = replicate level '#' ++ " " ++ haddockToMarkdown title++haddockToMarkdown (H.DocUnorderedList things)+  = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)+haddockToMarkdown (H.DocOrderedList things)+  = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)+haddockToMarkdown (H.DocDefList things)+  = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)++-- we cannot render math by default+haddockToMarkdown (H.DocMathInline _)+  = "*cannot render inline math formula*"+haddockToMarkdown (H.DocMathDisplay _)+  = "\n\n*cannot render display math formula*\n\n"++-- TODO: render tables+haddockToMarkdown (H.DocTable _t)+  = "\n\n*tables are not yet supported*\n\n"++-- things I don't really know how to handle+haddockToMarkdown (H.DocProperty _)+  = ""  -- don't really know what to do++escapeBackticks :: String -> String+escapeBackticks "" = ""+escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss+escapeBackticks (s  :ss) = s:escapeBackticks ss++removeUnescapedBackticks :: String -> String+removeUnescapedBackticks = \case+  '\\' : '`' : ss -> '\\' : '`' : removeUnescapedBackticks ss+  '`' : ss -> removeUnescapedBackticks ss+  "" -> ""+  s : ss -> s : removeUnescapedBackticks ss++splitForList :: String -> String+splitForList s+  = case lines s of+      [] -> ""+      (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest
src/Development/IDE/Spans/Documentation.hs view
@@ -1,226 +1,226 @@-{-# LANGUAGE RankNTypes #-}
--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE CPP #-}
-#include "ghc-api-version.h"
-
-module Development.IDE.Spans.Documentation (
-    getDocumentation
-  , getDocumentationTryGhc
-  , getDocumentationsTryGhc
-  , DocMap
-  , mkDocMap
-  ) where
-
-import           Control.Monad
-import           Control.Monad.Extra (findM)
-import           Data.Either
-import           Data.Foldable
-import           Data.List.Extra
-import qualified Data.Map as M
-import qualified Data.Set as S
-import           Data.Maybe
-import qualified Data.Text as T
-import           Development.IDE.Core.Compile
-import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Error
-import           Development.IDE.Spans.Common
-import           Development.IDE.Core.RuleTypes
-import           System.Directory
-import           System.FilePath
-
-import           FastString
-import           SrcLoc (RealLocated)
-import           GhcMonad
-import           Packages
-import           Name
-import           Language.Haskell.LSP.Types (getUri, filePathToUri)
-import           TcRnTypes
-import           ExtractDocs
-import           NameEnv
-import HscTypes (HscEnv(hsc_dflags))
-
-mkDocMap
-  :: HscEnv
-  -> [ParsedModule]
-  -> RefMap
-  -> TcGblEnv
-  -> IO DocAndKindMap
-mkDocMap env sources rm this_mod =
-  do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
-     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
-     k <- foldrM getType (tcg_type_env this_mod) names
-     pure $ DKMap d k
-  where
-    getDocs n map
-      | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
-      | otherwise = do
-      doc <- getDocumentationTryGhc env mod sources n
-      pure $ extendNameEnv map n doc
-    getType n map
-      | isTcOcc $ occName n = do
-        kind <- lookupKind env mod n
-        pure $ maybe map (extendNameEnv map n) kind
-      | otherwise = pure map
-    names = rights $ S.toList idents
-    idents = M.keysSet rm
-    mod = tcg_mod this_mod
-
-lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
-lookupKind env mod =
-    fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
-
-getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc
-getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n]
-
-getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]
--- Interfaces are only generated for GHC >= 8.6.
--- In older versions, interface files do not embed Haddocks anyway
-getDocumentationsTryGhc env mod sources names = do
-  res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
-  case res of
-      Left _ -> mapM mkSpanDocText names
-      Right res -> zipWithM unwrap res names
-  where
-    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n
-    unwrap _ n = mkSpanDocText n
-
-    mkSpanDocText name =
-      SpanDocText (getDocumentation sources name) <$> getUris name
-
-    -- Get the uris to the documentation and source html pages if they exist
-    getUris name = do
-      let df = hsc_dflags env
-      (docFu, srcFu) <-
-        case nameModule_maybe name of
-          Just mod -> liftIO $ do
-            doc <- toFileUriText $ lookupDocHtmlForModule df mod
-            src <- toFileUriText $ lookupSrcHtmlForModule df mod
-            return (doc, src)
-          Nothing -> pure (Nothing, Nothing)
-      let docUri = (<> "#" <> selector <> showName name) <$> docFu
-          srcUri = (<> "#" <> showName name) <$> srcFu
-          selector
-            | isValName name = "v:"
-            | otherwise = "t:"
-      return $ SpanDocUris docUri srcUri
-
-    toFileUriText = (fmap . fmap) (getUri . filePathToUri)
-
-getDocumentation
- :: HasSrcSpan name
- => [ParsedModule] -- ^ All of the possible modules it could be defined in.
- ->  name -- ^ The name you want documentation for.
- -> [T.Text]
--- This finds any documentation between the name you want
--- documentation for and the one before it. This is only an
--- approximately correct algorithm and there are easily constructed
--- cases where it will be wrong (if so then usually slightly but there
--- may be edge cases where it is very wrong).
--- TODO : Build a version of GHC exactprint to extract this information
--- more accurately.
-getDocumentation sources targetName = fromMaybe [] $ do
-  -- Find the module the target is defined in.
-  targetNameSpan <- realSpan $ getLoc targetName
-  tc <-
-    find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
-      $ reverse sources -- TODO : Is reversing the list here really neccessary?
-
-  -- Top level names bound by the module
-  let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
-           , L _ (ValD _ hsbind) <- hsmodDecls
-           , Just n <- [name_of_bind hsbind]
-           ]
-  -- Sort the names' source spans.
-  let sortedSpans = sortedNameSpans bs
-  -- Now go ahead and extract the docs.
-  let docs = ann tc
-  nameInd <- elemIndex targetNameSpan sortedSpans
-  let prevNameSpan =
-        if nameInd >= 1
-        then sortedSpans !! (nameInd - 1)
-        else zeroSpan $ srcSpanFile targetNameSpan
-  -- Annoyingly "-- |" documentation isn't annotated with a location,
-  -- so you have to pull it out from the elements.
-  pure
-      $ docHeaders
-      $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
-      $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v)
-      $ join
-      $ M.elems
-      docs
-  where
-    -- Get the name bound by a binding. We only concern ourselves with
-    -- @FunBind@ (which covers functions and variables).
-    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
-    name_of_bind FunBind {fun_id} = Just fun_id
-    name_of_bind _ = Nothing
-    -- Get source spans from names, discard unhelpful spans, remove
-    -- duplicates and sort.
-    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
-    sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
-    isBetween target before after = before <= target && target <= after
-    ann = snd . pm_annotations
-    annotationFileName :: ParsedModule -> Maybe FastString
-    annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
-    realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
-    realSpans =
-        mapMaybe (realSpan . getLoc)
-      . join
-      . M.elems
-
--- | Shows this part of the documentation
-docHeaders :: [RealLocated AnnotationComment]
-           -> [T.Text]
-docHeaders = mapMaybe (\(L _ x) -> wrk x)
-  where
-  wrk = \case
-    -- When `Opt_Haddock` is enabled.
-    AnnDocCommentNext s -> Just $ T.pack s
-    -- When `Opt_KeepRawTokenStream` enabled.
-    AnnLineComment s  -> if "-- |" `isPrefixOf` s
-                            then Just $ T.pack s
-                            else Nothing
-    _ -> Nothing
-
--- These are taken from haskell-ide-engine's Haddock plugin
-
--- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
--- An example for a cabal installed module:
--- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@
-lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
-lookupDocHtmlForModule =
-  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
-
--- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
--- An example for a cabal installed module:
--- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@
-lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
-lookupSrcHtmlForModule =
-  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
-
-lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath)
-lookupHtmlForModule mkDocPath df m = do
-  -- try all directories
-  let mfs = fmap (concatMap go) (lookupHtmls df ui)
-  html <- findM doesFileExist (concat . maybeToList $ mfs)
-  -- canonicalize located html to remove /../ indirection which can break some clients
-  -- (vscode on Windows at least)
-  traverse canonicalizePath html
-  where
-    go pkgDocDir = map (mkDocPath pkgDocDir) mns
-    ui = moduleUnitId m
-    -- try to locate html file from most to least specific name e.g.
-    --  first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html
-    --  then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc.
-    mns = do
-      chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m
-      -- The file might use "." or "-" as separator
-      map (`intercalate` chunks) [".", "-"]
-
-lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]
-lookupHtmls df ui =
-  -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path
-  -- and therefore doesn't expand $topdir on Windows
-  map takeDirectory . haddockInterfaces <$> lookupPackage df ui
+{-# LANGUAGE RankNTypes #-}+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"++module Development.IDE.Spans.Documentation (+    getDocumentation+  , getDocumentationTryGhc+  , getDocumentationsTryGhc+  , DocMap+  , mkDocMap+  ) where++import           Control.Monad+import           Control.Monad.Extra (findM)+import           Data.Either+import           Data.Foldable+import           Data.List.Extra+import qualified Data.Map as M+import qualified Data.Set as S+import           Data.Maybe+import qualified Data.Text as T+import           Development.IDE.Core.Compile+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Error+import           Development.IDE.Spans.Common+import           Development.IDE.Core.RuleTypes+import           System.Directory+import           System.FilePath++import           FastString+import           SrcLoc (RealLocated)+import           GhcMonad+import           Packages+import           Name+import           Language.Haskell.LSP.Types (getUri, filePathToUri)+import           TcRnTypes+import           ExtractDocs+import           NameEnv+import HscTypes (HscEnv(hsc_dflags))++mkDocMap+  :: HscEnv+  -> [ParsedModule]+  -> RefMap+  -> TcGblEnv+  -> IO DocAndKindMap+mkDocMap env sources rm this_mod =+  do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod+     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names+     k <- foldrM getType (tcg_type_env this_mod) names+     pure $ DKMap d k+  where+    getDocs n map+      | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist+      | otherwise = do+      doc <- getDocumentationTryGhc env mod sources n+      pure $ extendNameEnv map n doc+    getType n map+      | isTcOcc $ occName n = do+        kind <- lookupKind env mod n+        pure $ maybe map (extendNameEnv map n) kind+      | otherwise = pure map+    names = rights $ S.toList idents+    idents = M.keysSet rm+    mod = tcg_mod this_mod++lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)+lookupKind env mod =+    fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod++getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc+getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n]++getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]+-- Interfaces are only generated for GHC >= 8.6.+-- In older versions, interface files do not embed Haddocks anyway+getDocumentationsTryGhc env mod sources names = do+  res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names+  case res of+      Left _ -> mapM mkSpanDocText names+      Right res -> zipWithM unwrap res names+  where+    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n+    unwrap _ n = mkSpanDocText n++    mkSpanDocText name =+      SpanDocText (getDocumentation sources name) <$> getUris name++    -- Get the uris to the documentation and source html pages if they exist+    getUris name = do+      let df = hsc_dflags env+      (docFu, srcFu) <-+        case nameModule_maybe name of+          Just mod -> liftIO $ do+            doc <- toFileUriText $ lookupDocHtmlForModule df mod+            src <- toFileUriText $ lookupSrcHtmlForModule df mod+            return (doc, src)+          Nothing -> pure (Nothing, Nothing)+      let docUri = (<> "#" <> selector <> showName name) <$> docFu+          srcUri = (<> "#" <> showName name) <$> srcFu+          selector+            | isValName name = "v:"+            | otherwise = "t:"+      return $ SpanDocUris docUri srcUri++    toFileUriText = (fmap . fmap) (getUri . filePathToUri)++getDocumentation+ :: HasSrcSpan name+ => [ParsedModule] -- ^ All of the possible modules it could be defined in.+ ->  name -- ^ The name you want documentation for.+ -> [T.Text]+-- This finds any documentation between the name you want+-- documentation for and the one before it. This is only an+-- approximately correct algorithm and there are easily constructed+-- cases where it will be wrong (if so then usually slightly but there+-- may be edge cases where it is very wrong).+-- TODO : Build a version of GHC exactprint to extract this information+-- more accurately.+getDocumentation sources targetName = fromMaybe [] $ do+  -- Find the module the target is defined in.+  targetNameSpan <- realSpan $ getLoc targetName+  tc <-+    find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)+      $ reverse sources -- TODO : Is reversing the list here really neccessary?++  -- Top level names bound by the module+  let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc+           , L _ (ValD _ hsbind) <- hsmodDecls+           , Just n <- [name_of_bind hsbind]+           ]+  -- Sort the names' source spans.+  let sortedSpans = sortedNameSpans bs+  -- Now go ahead and extract the docs.+  let docs = ann tc+  nameInd <- elemIndex targetNameSpan sortedSpans+  let prevNameSpan =+        if nameInd >= 1+        then sortedSpans !! (nameInd - 1)+        else zeroSpan $ srcSpanFile targetNameSpan+  -- Annoyingly "-- |" documentation isn't annotated with a location,+  -- so you have to pull it out from the elements.+  pure+      $ docHeaders+      $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)+      $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v)+      $ join+      $ M.elems+      docs+  where+    -- Get the name bound by a binding. We only concern ourselves with+    -- @FunBind@ (which covers functions and variables).+    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)+    name_of_bind FunBind {fun_id} = Just fun_id+    name_of_bind _ = Nothing+    -- Get source spans from names, discard unhelpful spans, remove+    -- duplicates and sort.+    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]+    sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)+    isBetween target before after = before <= target && target <= after+    ann = snd . pm_annotations+    annotationFileName :: ParsedModule -> Maybe FastString+    annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann+    realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]+    realSpans =+        mapMaybe (realSpan . getLoc)+      . join+      . M.elems++-- | Shows this part of the documentation+docHeaders :: [RealLocated AnnotationComment]+           -> [T.Text]+docHeaders = mapMaybe (\(L _ x) -> wrk x)+  where+  wrk = \case+    -- When `Opt_Haddock` is enabled.+    AnnDocCommentNext s -> Just $ T.pack s+    -- When `Opt_KeepRawTokenStream` enabled.+    AnnLineComment s  -> if "-- |" `isPrefixOf` s+                            then Just $ T.pack s+                            else Nothing+    _ -> Nothing++-- These are taken from haskell-ide-engine's Haddock plugin++-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.+-- An example for a cabal installed module:+-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@+lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)+lookupDocHtmlForModule =+  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")++-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.+-- An example for a cabal installed module:+-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@+lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)+lookupSrcHtmlForModule =+  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")++lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath)+lookupHtmlForModule mkDocPath df m = do+  -- try all directories+  let mfs = fmap (concatMap go) (lookupHtmls df ui)+  html <- findM doesFileExist (concat . maybeToList $ mfs)+  -- canonicalize located html to remove /../ indirection which can break some clients+  -- (vscode on Windows at least)+  traverse canonicalizePath html+  where+    go pkgDocDir = map (mkDocPath pkgDocDir) mns+    ui = moduleUnitId m+    -- try to locate html file from most to least specific name e.g.+    --  first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html+    --  then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc.+    mns = do+      chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m+      -- The file might use "." or "-" as separator+      map (`intercalate` chunks) [".", "-"]++lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]+lookupHtmls df ui =+  -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path+  -- and therefore doesn't expand $topdir on Windows+  map takeDirectory . haddockInterfaces <$> lookupPackage df ui
src/Development/IDE/Spans/LocalBindings.hs view
@@ -1,134 +1,134 @@-{-# LANGUAGE DerivingStrategies #-}
-
-module Development.IDE.Spans.LocalBindings
-  ( Bindings
-  , getLocalScope
-  , getFuzzyScope
-  , getDefiningBindings
-  , getFuzzyDefiningBindings
-  , bindings
-  ) where
-
-import           Control.DeepSeq
-import           Control.Monad
-import           Data.Bifunctor
-import           Data.IntervalMap.FingerTree (IntervalMap, Interval (..))
-import qualified Data.IntervalMap.FingerTree as IM
-import qualified Data.List as L
-import qualified Data.Map as M
-import qualified Data.Set as S
-import           Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type)
-import           Development.IDE.GHC.Error
-import           Development.IDE.Types.Location
-import           NameEnv
-import           SrcLoc
-
-------------------------------------------------------------------------------
--- | Turn a 'RealSrcSpan' into an 'Interval'.
-realSrcSpanToInterval :: RealSrcSpan -> Interval Position
-realSrcSpanToInterval rss =
-  Interval
-    (realSrcLocToPosition $ realSrcSpanStart rss)
-    (realSrcLocToPosition $ realSrcSpanEnd   rss)
-
-bindings :: RefMap -> Bindings
-bindings = uncurry Bindings . localBindings
-
-------------------------------------------------------------------------------
--- | Compute which identifiers are in scope at every point in the AST. Use
--- 'getLocalScope' to find the results.
-localBindings
-    :: RefMap
-    -> ( IntervalMap Position (NameEnv (Name, Maybe Type))
-       , IntervalMap Position (NameEnv (Name, Maybe Type))
-       )
-localBindings refmap = bimap mk mk $ unzip $ do
-  (ident, refs)      <- M.toList refmap
-  Right name         <- pure ident
-  (_, ident_details) <- refs
-  let ty = identType ident_details
-  info <- S.toList $ identInfo ident_details
-  pure
-    ( do
-        Just scopes <- pure $ getScopeFromContext info
-        scope <- scopes >>= \case
-          LocalScope scope -> pure $ realSrcSpanToInterval scope
-          _ -> []
-        pure ( scope
-            , unitNameEnv name (name,ty)
-            )
-    , do
-        Just scope <- pure $ getBindSiteFromContext info
-        pure ( realSrcSpanToInterval scope
-            , unitNameEnv name (name,ty)
-            )
-    )
-  where
-    mk = L.foldl' (flip (uncurry IM.insert)) mempty . join
-
-------------------------------------------------------------------------------
--- | The available bindings at every point in a Haskell tree.
-data Bindings = Bindings
-  { getLocalBindings
-        :: IntervalMap Position (NameEnv (Name, Maybe Type))
-  , getBindingSites
-        :: IntervalMap Position (NameEnv (Name, Maybe Type))
-  }
-
-instance Semigroup Bindings where
-  Bindings a1 b1 <> Bindings a2 b2
-    = Bindings (a1 <> a2) (b1 <> b2)
-
-instance Monoid Bindings where
-  mempty = Bindings mempty mempty
-
-instance NFData Bindings where
-    rnf = rwhnf
-
-instance Show Bindings where
-    show _ = "<bindings>"
-
-
-------------------------------------------------------------------------------
--- | Given a 'Bindings' get every identifier in scope at the given
--- 'RealSrcSpan',
-getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
-getLocalScope bs rss
-  = nameEnvElts
-  $ foldMap snd
-  $ IM.dominators (realSrcSpanToInterval rss)
-  $ getLocalBindings bs
-
-------------------------------------------------------------------------------
--- | Given a 'Bindings', get every binding currently active at a given
--- 'RealSrcSpan',
-getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
-getDefiningBindings bs rss
-  = nameEnvElts
-  $ foldMap snd
-  $ IM.dominators (realSrcSpanToInterval rss)
-  $ getBindingSites bs
-
-
--- | Lookup all names in scope in any span that intersects the interval
--- defined by the two positions.
--- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`
-getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
-getFuzzyScope bs a b
-  = nameEnvElts
-  $ foldMap snd
-  $ IM.intersections (Interval a b)
-  $ getLocalBindings bs
-
-------------------------------------------------------------------------------
--- | Given a 'Bindings', get every binding that intersects the interval defined
--- by the two positions.
--- This is meant for use with the fuzzy `PositionRange` returned by
--- `PositionMapping`
-getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
-getFuzzyDefiningBindings bs a b
-  = nameEnvElts
-  $ foldMap snd
-  $ IM.intersections (Interval a b)
-  $ getBindingSites bs
-
+{-# LANGUAGE DerivingStrategies #-}++module Development.IDE.Spans.LocalBindings+  ( Bindings+  , getLocalScope+  , getFuzzyScope+  , getDefiningBindings+  , getFuzzyDefiningBindings+  , bindings+  ) where++import           Control.DeepSeq+import           Control.Monad+import           Data.Bifunctor+import           Data.IntervalMap.FingerTree (IntervalMap, Interval (..))+import qualified Data.IntervalMap.FingerTree as IM+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S+import           Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type)+import           Development.IDE.GHC.Error+import           Development.IDE.Types.Location+import           NameEnv+import           SrcLoc++------------------------------------------------------------------------------+-- | Turn a 'RealSrcSpan' into an 'Interval'.+realSrcSpanToInterval :: RealSrcSpan -> Interval Position+realSrcSpanToInterval rss =+  Interval+    (realSrcLocToPosition $ realSrcSpanStart rss)+    (realSrcLocToPosition $ realSrcSpanEnd   rss)++bindings :: RefMap -> Bindings+bindings = uncurry Bindings . localBindings++------------------------------------------------------------------------------+-- | Compute which identifiers are in scope at every point in the AST. Use+-- 'getLocalScope' to find the results.+localBindings+    :: RefMap+    -> ( IntervalMap Position (NameEnv (Name, Maybe Type))+       , IntervalMap Position (NameEnv (Name, Maybe Type))+       )+localBindings refmap = bimap mk mk $ unzip $ do+  (ident, refs)      <- M.toList refmap+  Right name         <- pure ident+  (_, ident_details) <- refs+  let ty = identType ident_details+  info <- S.toList $ identInfo ident_details+  pure+    ( do+        Just scopes <- pure $ getScopeFromContext info+        scope <- scopes >>= \case+          LocalScope scope -> pure $ realSrcSpanToInterval scope+          _ -> []+        pure ( scope+            , unitNameEnv name (name,ty)+            )+    , do+        Just scope <- pure $ getBindSiteFromContext info+        pure ( realSrcSpanToInterval scope+            , unitNameEnv name (name,ty)+            )+    )+  where+    mk = L.foldl' (flip (uncurry IM.insert)) mempty . join++------------------------------------------------------------------------------+-- | The available bindings at every point in a Haskell tree.+data Bindings = Bindings+  { getLocalBindings+        :: IntervalMap Position (NameEnv (Name, Maybe Type))+  , getBindingSites+        :: IntervalMap Position (NameEnv (Name, Maybe Type))+  }++instance Semigroup Bindings where+  Bindings a1 b1 <> Bindings a2 b2+    = Bindings (a1 <> a2) (b1 <> b2)++instance Monoid Bindings where+  mempty = Bindings mempty mempty++instance NFData Bindings where+    rnf = rwhnf++instance Show Bindings where+    show _ = "<bindings>"+++------------------------------------------------------------------------------+-- | Given a 'Bindings' get every identifier in scope at the given+-- 'RealSrcSpan',+getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]+getLocalScope bs rss+  = nameEnvElts+  $ foldMap snd+  $ IM.dominators (realSrcSpanToInterval rss)+  $ getLocalBindings bs++------------------------------------------------------------------------------+-- | Given a 'Bindings', get every binding currently active at a given+-- 'RealSrcSpan',+getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]+getDefiningBindings bs rss+  = nameEnvElts+  $ foldMap snd+  $ IM.dominators (realSrcSpanToInterval rss)+  $ getBindingSites bs+++-- | Lookup all names in scope in any span that intersects the interval+-- defined by the two positions.+-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`+getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]+getFuzzyScope bs a b+  = nameEnvElts+  $ foldMap snd+  $ IM.intersections (Interval a b)+  $ getLocalBindings bs++------------------------------------------------------------------------------+-- | Given a 'Bindings', get every binding that intersects the interval defined+-- by the two positions.+-- This is meant for use with the fuzzy `PositionRange` returned by+-- `PositionMapping`+getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)]+getFuzzyDefiningBindings bs a b+  = nameEnvElts+  $ foldMap snd+  $ IM.intersections (Interval a b)+  $ getBindingSites bs+
src/Development/IDE/Types/Action.hs view
@@ -1,88 +1,88 @@-module Development.IDE.Types.Action
-  ( DelayedAction (..),
-    DelayedActionInternal,
-    ActionQueue,
-    newQueue,
-    pushQueue,
-    popQueue,
-    doneQueue,
-    peekInProgress,
-  abortQueue,countQueue)
-where
-
-import           Control.Concurrent.STM
-import           Data.Hashable                (Hashable (..))
-import           Data.HashSet                 (HashSet)
-import qualified Data.HashSet                 as Set
-import           Data.Unique                  (Unique)
-import           Development.IDE.Types.Logger
-import           Development.Shake            (Action)
-import           Numeric.Natural
-
-data DelayedAction a = DelayedAction
-  { uniqueID       :: Maybe Unique,
-    -- | Name we use for debugging
-    actionName     :: String,
-    -- | Priority with which to log the action
-    actionPriority :: Priority,
-    -- | The payload
-    getAction      :: Action a
-  }
-  deriving (Functor)
-
-type DelayedActionInternal = DelayedAction ()
-
-instance Eq (DelayedAction a) where
-  a == b = uniqueID a == uniqueID b
-
-instance Hashable (DelayedAction a) where
-  hashWithSalt s = hashWithSalt s . uniqueID
-
-instance Show (DelayedAction a) where
-  show d = "DelayedAction: " ++ actionName d
-
-------------------------------------------------------------------------------
-
-data ActionQueue = ActionQueue
-  { newActions :: TQueue DelayedActionInternal,
-    inProgress :: TVar (HashSet DelayedActionInternal)
-  }
-
-newQueue :: IO ActionQueue
-newQueue = atomically $ do
-  newActions <- newTQueue
-  inProgress <- newTVar mempty
-  return ActionQueue {..}
-
-pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()
-pushQueue act ActionQueue {..} = writeTQueue newActions act
-
--- | You must call 'doneQueue' to signal completion
-popQueue :: ActionQueue -> STM DelayedActionInternal
-popQueue ActionQueue {..} = do
-  x <- readTQueue newActions
-  modifyTVar inProgress (Set.insert x)
-  return x
-
--- | Completely remove an action from the queue
-abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
-abortQueue x ActionQueue {..} = do
-  qq <- flushTQueue newActions
-  mapM_ (writeTQueue newActions) (filter (/= x) qq)
-  modifyTVar inProgress (Set.delete x)
-
--- | Mark an action as complete when called after 'popQueue'.
---   Has no effect otherwise
-doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
-doneQueue x ActionQueue {..} = do
-  modifyTVar inProgress (Set.delete x)
-
-countQueue :: ActionQueue -> STM Natural
-countQueue ActionQueue{..} = do
-    backlog <- flushTQueue newActions
-    mapM_ (writeTQueue newActions) backlog
-    m <- Set.size <$> readTVar inProgress
-    return $ fromIntegral $ length backlog + m
-
-peekInProgress :: ActionQueue -> STM [DelayedActionInternal]
-peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress
+module Development.IDE.Types.Action+  ( DelayedAction (..),+    DelayedActionInternal,+    ActionQueue,+    newQueue,+    pushQueue,+    popQueue,+    doneQueue,+    peekInProgress,+  abortQueue,countQueue)+where++import           Control.Concurrent.STM+import           Data.Hashable                (Hashable (..))+import           Data.HashSet                 (HashSet)+import qualified Data.HashSet                 as Set+import           Data.Unique                  (Unique)+import           Development.IDE.Types.Logger+import           Development.Shake            (Action)+import           Numeric.Natural++data DelayedAction a = DelayedAction+  { uniqueID       :: Maybe Unique,+    -- | Name we use for debugging+    actionName     :: String,+    -- | Priority with which to log the action+    actionPriority :: Priority,+    -- | The payload+    getAction      :: Action a+  }+  deriving (Functor)++type DelayedActionInternal = DelayedAction ()++instance Eq (DelayedAction a) where+  a == b = uniqueID a == uniqueID b++instance Hashable (DelayedAction a) where+  hashWithSalt s = hashWithSalt s . uniqueID++instance Show (DelayedAction a) where+  show d = "DelayedAction: " ++ actionName d++------------------------------------------------------------------------------++data ActionQueue = ActionQueue+  { newActions :: TQueue DelayedActionInternal,+    inProgress :: TVar (HashSet DelayedActionInternal)+  }++newQueue :: IO ActionQueue+newQueue = atomically $ do+  newActions <- newTQueue+  inProgress <- newTVar mempty+  return ActionQueue {..}++pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()+pushQueue act ActionQueue {..} = writeTQueue newActions act++-- | You must call 'doneQueue' to signal completion+popQueue :: ActionQueue -> STM DelayedActionInternal+popQueue ActionQueue {..} = do+  x <- readTQueue newActions+  modifyTVar inProgress (Set.insert x)+  return x++-- | Completely remove an action from the queue+abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()+abortQueue x ActionQueue {..} = do+  qq <- flushTQueue newActions+  mapM_ (writeTQueue newActions) (filter (/= x) qq)+  modifyTVar inProgress (Set.delete x)++-- | Mark an action as complete when called after 'popQueue'.+--   Has no effect otherwise+doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()+doneQueue x ActionQueue {..} = do+  modifyTVar inProgress (Set.delete x)++countQueue :: ActionQueue -> STM Natural+countQueue ActionQueue{..} = do+    backlog <- flushTQueue newActions+    mapM_ (writeTQueue newActions) backlog+    m <- Set.size <$> readTVar inProgress+    return $ fromIntegral $ length backlog + m++peekInProgress :: ActionQueue -> STM [DelayedActionInternal]+peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress
src/Development/IDE/Types/Diagnostics.hs view
@@ -1,151 +1,151 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-
-module Development.IDE.Types.Diagnostics (
-  LSP.Diagnostic(..),
-  ShowDiagnostic(..),
-  FileDiagnostic,
-  IdeResult,
-  LSP.DiagnosticSeverity(..),
-  DiagnosticStore,
-  List(..),
-  ideErrorText,
-  ideErrorWithSource,
-  showDiagnostics,
-  showDiagnosticsColored,
-  ) where
-
-import Control.DeepSeq
-import Data.Maybe as Maybe
-import qualified Data.Text as T
-import Data.Text.Prettyprint.Doc
-import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
-    DiagnosticSeverity(..)
-  , Diagnostic(..)
-  , List(..)
-  )
-import Language.Haskell.LSP.Diagnostics
-import Data.Text.Prettyprint.Doc.Render.Text
-import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
-import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)
-
-import Development.IDE.Types.Location
-
-
--- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
---   and a value is in the Maybe. For operations that throw an error you
---   expect a non-empty list of diagnostics, at least one of which is an error,
---   and a Nothing. For operations that succeed you expect perhaps some warnings
---   and a Just. For operations that depend on other failing operations you may
---   get empty diagnostics and a Nothing, to indicate this phase throws no fresh
---   errors but still failed.
---
---   A rule on a file should only return diagnostics for that given file. It should
---   not propagate diagnostic errors through multiple phases.
-type IdeResult v = ([FileDiagnostic], Maybe v)
-
-ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
-ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
-
-ideErrorWithSource
-  :: Maybe DiagnosticSource
-  -> Maybe DiagnosticSeverity
-  -> a
-  -> T.Text
-  -> (a, ShowDiagnostic, Diagnostic)
-ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
-    _range = noRange,
-    _severity = sev,
-    _code = Nothing,
-    _source = source,
-    _message = msg,
-    _relatedInformation = Nothing,
-    _tags = Nothing
-    })
-
--- | Defines whether a particular diagnostic should be reported
---   back to the user.
---
---   One important use case is "missing signature" code lenses,
---   for which we need to enable the corresponding warning during
---   type checking. However, we do not want to show the warning
---   unless the programmer asks for it (#261).
-data ShowDiagnostic
-    = ShowDiag  -- ^ Report back to the user
-    | HideDiag  -- ^ Hide from user
-    deriving (Eq, Ord, Show)
-
-instance NFData ShowDiagnostic where
-    rnf = rwhnf
-
--- | Human readable diagnostics for a specific file.
---
---   This type packages a pretty printed, human readable error message
---   along with the related source location so that we can display the error
---   on either the console or in the IDE at the right source location.
---
-type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
-
-prettyRange :: Range -> Doc Terminal.AnsiStyle
-prettyRange Range{..} = f _start <> "-" <> f _end
-    where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1)
-
-stringParagraphs :: T.Text -> Doc a
-stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines
-
-showDiagnostics :: [FileDiagnostic] -> T.Text
-showDiagnostics = srenderPlain . prettyDiagnostics
-
-showDiagnosticsColored :: [FileDiagnostic] -> T.Text
-showDiagnosticsColored = srenderColored . prettyDiagnostics
-
-
-prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
-prettyDiagnostics = vcat . map prettyDiagnostic
-
-prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
-prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =
-    vcat
-        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)
-        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"
-        , slabel_ "Range:   " $ prettyRange _range
-        , slabel_ "Source:  " $ pretty _source
-        , slabel_ "Severity:" $ pretty $ show sev
-        , slabel_ "Message: "
-            $ case sev of
-              LSP.DsError -> annotate $ color Red
-              LSP.DsWarning -> annotate $ color Yellow
-              LSP.DsInfo -> annotate $ color Blue
-              LSP.DsHint -> annotate $ color Magenta
-            $ stringParagraphs _message
-        ]
-    where
-        sev = fromMaybe LSP.DsError _severity
-
-
--- | Label a document.
-slabel_ :: String -> Doc a -> Doc a
-slabel_ t d = nest 2 $ sep [pretty t, d]
-
--- | The layout options used for the SDK assistant.
-cliLayout ::
-       Int
-    -- ^ Rendering width of the pretty printer.
-    -> LayoutOptions
-cliLayout renderWidth = LayoutOptions
-    { layoutPageWidth = AvailablePerLine renderWidth 0.9
-    }
-
--- | Render without any syntax annotations
-srenderPlain :: Doc ann -> T.Text
-srenderPlain = renderStrict . layoutSmart (cliLayout defaultTermWidth)
-
--- | Render a 'Document' as an ANSII colored string.
-srenderColored :: Doc Terminal.AnsiStyle -> T.Text
-srenderColored =
-    Terminal.renderStrict .
-    layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 }
-
-defaultTermWidth :: Int
-defaultTermWidth = 80
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+++module Development.IDE.Types.Diagnostics (+  LSP.Diagnostic(..),+  ShowDiagnostic(..),+  FileDiagnostic,+  IdeResult,+  LSP.DiagnosticSeverity(..),+  DiagnosticStore,+  List(..),+  ideErrorText,+  ideErrorWithSource,+  showDiagnostics,+  showDiagnosticsColored,+  ) where++import Control.DeepSeq+import Data.Maybe as Maybe+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,+    DiagnosticSeverity(..)+  , Diagnostic(..)+  , List(..)+  )+import Language.Haskell.LSP.Diagnostics+import Data.Text.Prettyprint.Doc.Render.Text+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal+import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)++import Development.IDE.Types.Location+++-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,+--   and a value is in the Maybe. For operations that throw an error you+--   expect a non-empty list of diagnostics, at least one of which is an error,+--   and a Nothing. For operations that succeed you expect perhaps some warnings+--   and a Just. For operations that depend on other failing operations you may+--   get empty diagnostics and a Nothing, to indicate this phase throws no fresh+--   errors but still failed.+--+--   A rule on a file should only return diagnostics for that given file. It should+--   not propagate diagnostic errors through multiple phases.+type IdeResult v = ([FileDiagnostic], Maybe v)++ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic+ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)++ideErrorWithSource+  :: Maybe DiagnosticSource+  -> Maybe DiagnosticSeverity+  -> a+  -> T.Text+  -> (a, ShowDiagnostic, Diagnostic)+ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {+    _range = noRange,+    _severity = sev,+    _code = Nothing,+    _source = source,+    _message = msg,+    _relatedInformation = Nothing,+    _tags = Nothing+    })++-- | Defines whether a particular diagnostic should be reported+--   back to the user.+--+--   One important use case is "missing signature" code lenses,+--   for which we need to enable the corresponding warning during+--   type checking. However, we do not want to show the warning+--   unless the programmer asks for it (#261).+data ShowDiagnostic+    = ShowDiag  -- ^ Report back to the user+    | HideDiag  -- ^ Hide from user+    deriving (Eq, Ord, Show)++instance NFData ShowDiagnostic where+    rnf = rwhnf++-- | Human readable diagnostics for a specific file.+--+--   This type packages a pretty printed, human readable error message+--   along with the related source location so that we can display the error+--   on either the console or in the IDE at the right source location.+--+type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)++prettyRange :: Range -> Doc Terminal.AnsiStyle+prettyRange Range{..} = f _start <> "-" <> f _end+    where f Position{..} = pretty (_line+1) <> colon <> pretty (_character+1)++stringParagraphs :: T.Text -> Doc a+stringParagraphs = vcat . map (fillSep . map pretty . T.words) . T.lines++showDiagnostics :: [FileDiagnostic] -> T.Text+showDiagnostics = srenderPlain . prettyDiagnostics++showDiagnosticsColored :: [FileDiagnostic] -> T.Text+showDiagnosticsColored = srenderColored . prettyDiagnostics+++prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle+prettyDiagnostics = vcat . map prettyDiagnostic++prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle+prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =+    vcat+        [ slabel_ "File:    " $ pretty (fromNormalizedFilePath fp)+        , slabel_ "Hidden:  " $ if sh == ShowDiag then "no" else "yes"+        , slabel_ "Range:   " $ prettyRange _range+        , slabel_ "Source:  " $ pretty _source+        , slabel_ "Severity:" $ pretty $ show sev+        , slabel_ "Message: "+            $ case sev of+              LSP.DsError -> annotate $ color Red+              LSP.DsWarning -> annotate $ color Yellow+              LSP.DsInfo -> annotate $ color Blue+              LSP.DsHint -> annotate $ color Magenta+            $ stringParagraphs _message+        ]+    where+        sev = fromMaybe LSP.DsError _severity+++-- | Label a document.+slabel_ :: String -> Doc a -> Doc a+slabel_ t d = nest 2 $ sep [pretty t, d]++-- | The layout options used for the SDK assistant.+cliLayout ::+       Int+    -- ^ Rendering width of the pretty printer.+    -> LayoutOptions+cliLayout renderWidth = LayoutOptions+    { layoutPageWidth = AvailablePerLine renderWidth 0.9+    }++-- | Render without any syntax annotations+srenderPlain :: Doc ann -> T.Text+srenderPlain = renderStrict . layoutSmart (cliLayout defaultTermWidth)++-- | Render a 'Document' as an ANSII colored string.+srenderColored :: Doc Terminal.AnsiStyle -> T.Text+srenderColored =+    Terminal.renderStrict .+    layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine 100 1.0 }++defaultTermWidth :: Int+defaultTermWidth = 80
src/Development/IDE/Types/Exports.hs view
@@ -1,92 +1,92 @@-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
-module Development.IDE.Types.Exports
-(
-    IdentInfo(..),
-    ExportsMap(..),
-    createExportsMap,
-    createExportsMapMg,
-    createExportsMapTc
-) where
-
-import Avail (AvailInfo(..))
-import Control.DeepSeq (NFData)
-import Data.Text (pack, Text)
-import Development.IDE.GHC.Compat
-import Development.IDE.GHC.Util
-import Data.HashMap.Strict (HashMap)
-import GHC.Generics (Generic)
-import Name
-import FieldLabel (flSelector)
-import qualified Data.HashMap.Strict as Map
-import GhcPlugins (IfaceExport, ModGuts(..))
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as Set
-import Data.Bifunctor (Bifunctor(second))
-import Data.Hashable (Hashable)
-import TcRnTypes(TcGblEnv(..))
-
-newtype ExportsMap = ExportsMap
-    {getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))}
-    deriving newtype (Monoid, NFData, Show)
-
-instance Semigroup ExportsMap where
-    ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b
-
-type IdentifierText = Text
-type ModuleNameText = Text
-
-data IdentInfo = IdentInfo
-    { name :: !Text
-    , rendered :: Text
-    , parent :: !(Maybe Text)
-    , isDatacon :: !Bool
-    }
-    deriving (Eq, Generic, Show)
-    deriving anyclass Hashable
-
-instance NFData IdentInfo
-
-mkIdentInfos :: AvailInfo -> [IdentInfo]
-mkIdentInfos (Avail n) =
-    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
-mkIdentInfos (AvailTC parent (n:nn) flds)
-    -- Following the GHC convention that parent == n if parent is exported
-    | n == parent
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
-        | n <- nn ++ map flSelector flds
-      ] ++
-      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
-    where
-        parentP = pack $ prettyPrint parent
-
-mkIdentInfos (AvailTC _ nn flds)
-    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
-        | n <- nn ++ map flSelector flds
-      ]
-
-createExportsMap :: [ModIface] -> ExportsMap
-createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne
-  where
-    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi)
-      where
-        mn = moduleName $ mi_module mi
-
-createExportsMapMg :: [ModGuts] -> ExportsMap
-createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne
-  where
-    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi)
-      where
-        mn = moduleName $ mg_module mi
-
-createExportsMapTc :: [TcGblEnv] -> ExportsMap
-createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne
-  where
-    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi)
-      where
-        mn = moduleName $ tcg_mod mi
-
-unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
-unpackAvail mod =
-  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))
-    . mkIdentInfos
+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+module Development.IDE.Types.Exports+(+    IdentInfo(..),+    ExportsMap(..),+    createExportsMap,+    createExportsMapMg,+    createExportsMapTc+) where++import Avail (AvailInfo(..))+import Control.DeepSeq (NFData)+import Data.Text (pack, Text)+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util+import Data.HashMap.Strict (HashMap)+import GHC.Generics (Generic)+import Name+import FieldLabel (flSelector)+import qualified Data.HashMap.Strict as Map+import GhcPlugins (IfaceExport, ModGuts(..))+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Bifunctor (Bifunctor(second))+import Data.Hashable (Hashable)+import TcRnTypes(TcGblEnv(..))++newtype ExportsMap = ExportsMap+    {getExportsMap :: HashMap IdentifierText (HashSet (IdentInfo,ModuleNameText))}+    deriving newtype (Monoid, NFData, Show)++instance Semigroup ExportsMap where+    ExportsMap a <> ExportsMap b = ExportsMap $ Map.unionWith (<>) a b++type IdentifierText = Text+type ModuleNameText = Text++data IdentInfo = IdentInfo+    { name :: !Text+    , rendered :: Text+    , parent :: !(Maybe Text)+    , isDatacon :: !Bool+    }+    deriving (Eq, Generic, Show)+    deriving anyclass Hashable++instance NFData IdentInfo++mkIdentInfos :: AvailInfo -> [IdentInfo]+mkIdentInfos (Avail n) =+    [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]+mkIdentInfos (AvailTC parent (n:nn) flds)+    -- Following the GHC convention that parent == n if parent is exported+    | n == parent+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n)+        | n <- nn ++ map flSelector flds+      ] +++      [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]+    where+        parentP = pack $ prettyPrint parent++mkIdentInfos (AvailTC _ nn flds)+    = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)+        | n <- nn ++ map flSelector flds+      ]++createExportsMap :: [ModIface] -> ExportsMap+createExportsMap = ExportsMap . Map.fromListWith (<>) . concatMap doOne+  where+    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mi_exports mi)+      where+        mn = moduleName $ mi_module mi++createExportsMapMg :: [ModGuts] -> ExportsMap+createExportsMapMg = ExportsMap . Map.fromListWith (<>) . concatMap doOne+  where+    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (mg_exports mi)+      where+        mn = moduleName $ mg_module mi++createExportsMapTc :: [TcGblEnv] -> ExportsMap+createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne+  where+    doOne mi = concatMap (fmap (second Set.fromList) . unpackAvail mn) (tcg_exports mi)+      where+        mn = moduleName $ tcg_mod mi++unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]+unpackAvail mod =+  map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))+    . mkIdentInfos
src/Development/IDE/Types/KnownTargets.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
-module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where
-
-import Data.HashMap.Strict
-import Development.IDE.Types.Location
-import Development.IDE.GHC.Compat (ModuleName)
-import Development.IDE.GHC.Orphans ()
-import Data.Hashable
-import GHC.Generics
-import Control.DeepSeq
-import Data.HashSet
-import qualified Data.HashSet as HSet
-import qualified Data.HashMap.Strict as HMap
-
--- | A mapping of module name to known files
-type KnownTargets = HashMap Target [NormalizedFilePath]
-
-data Target = TargetModule ModuleName | TargetFile NormalizedFilePath
-  deriving ( Eq, Generic, Show )
-  deriving anyclass (Hashable, NFData)
-
-toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath
-toKnownFiles = HSet.fromList . concat . HMap.elems
+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where++import Data.HashMap.Strict+import Development.IDE.Types.Location+import Development.IDE.GHC.Compat (ModuleName)+import Development.IDE.GHC.Orphans ()+import Data.Hashable+import GHC.Generics+import Control.DeepSeq+import Data.HashSet+import qualified Data.HashSet as HSet+import qualified Data.HashMap.Strict as HMap++-- | A mapping of module name to known files+type KnownTargets = HashMap Target [NormalizedFilePath]++data Target = TargetModule ModuleName | TargetFile NormalizedFilePath+  deriving ( Eq, Generic, Show )+  deriving anyclass (Hashable, NFData)++toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath+toKnownFiles = HSet.fromList . concat . HMap.elems
src/Development/IDE/Types/Location.hs view
@@ -1,112 +1,112 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-
--- | Types and functions for working with source code locations.
-module Development.IDE.Types.Location
-    ( Location(..)
-    , noFilePath
-    , noRange
-    , Position(..)
-    , showPosition
-    , Range(..)
-    , LSP.Uri(..)
-    , LSP.NormalizedUri
-    , LSP.toNormalizedUri
-    , LSP.fromNormalizedUri
-    , LSP.NormalizedFilePath
-    , fromUri
-    , emptyFilePath
-    , emptyPathUri
-    , toNormalizedFilePath'
-    , LSP.fromNormalizedFilePath
-    , filePathToUri'
-    , uriToFilePath'
-    , readSrcSpan
-    ) where
-
-import Control.Applicative
-import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
-import Control.Monad
-import Data.Hashable (Hashable(hash))
-import Data.String
-import FastString
-import qualified Language.Haskell.LSP.Types as LSP
-import SrcLoc as GHC
-import Text.ParserCombinators.ReadP as ReadP
-import Data.Maybe (fromMaybe)
-
-toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
--- We want to keep empty paths instead of normalising them to "."
-toNormalizedFilePath' "" = emptyFilePath
-toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp
-
-emptyFilePath :: LSP.NormalizedFilePath
-emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
-
--- | We use an empty string as a filepath when we don’t have a file.
--- However, haskell-lsp doesn’t support that in uriToFilePath and given
--- that it is not a valid filepath it does not make sense to upstream a fix.
--- So we have our own wrapper here that supports empty filepaths.
-uriToFilePath' :: LSP.Uri -> Maybe FilePath
-uriToFilePath' uri
-    | uri == LSP.fromNormalizedUri emptyPathUri = Just ""
-    | otherwise = LSP.uriToFilePath uri
-
-emptyPathUri :: LSP.NormalizedUri
-emptyPathUri =
-    let s = "file://"
-    in LSP.NormalizedUri (hash s) s
-
-filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
-filePathToUri' = LSP.normalizedFilePathToUri
-
-fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
-fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath
-
-noFilePath :: FilePath
-noFilePath = "<unknown>"
-
--- A dummy range to use when range is unknown
-noRange :: Range
-noRange =  Range (Position 0 0) (Position 1 0)
-
-showPosition :: Position -> String
-showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)
-
--- | Parser for the GHC output format
-readSrcSpan :: ReadS RealSrcSpan
-readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)
-  where
-    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan
-    singleLineSrcSpanP = do
-      fp <- filePathP
-      l  <- readS_to_P reads <* char ':'
-      c0 <- readS_to_P reads
-      c1 <- (char '-' *> readS_to_P reads) <|> pure c0
-      let from = mkRealSrcLoc fp l c0
-          to   = mkRealSrcLoc fp l c1
-      return $ mkRealSrcSpan from to
-
-    multiLineSrcSpanP = do
-      fp <- filePathP
-      s <- parensP (srcLocP fp)
-      void $ char '-'
-      e <- parensP (srcLocP fp)
-      return $ mkRealSrcSpan s e
-
-    parensP :: ReadP a -> ReadP a
-    parensP = between (char '(') (char ')')
-
-    filePathP :: ReadP FastString
-    filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""
-
-    srcLocP :: FastString -> ReadP RealSrcLoc
-    srcLocP fp = do
-      l <- readS_to_P reads
-      void $ char ','
-      c <- readS_to_P reads
-      return $ mkRealSrcLoc fp l c
-
-    readFilePath :: ReadP FilePath
-    readFilePath = some ReadP.get
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0+++-- | Types and functions for working with source code locations.+module Development.IDE.Types.Location+    ( Location(..)+    , noFilePath+    , noRange+    , Position(..)+    , showPosition+    , Range(..)+    , LSP.Uri(..)+    , LSP.NormalizedUri+    , LSP.toNormalizedUri+    , LSP.fromNormalizedUri+    , LSP.NormalizedFilePath+    , fromUri+    , emptyFilePath+    , emptyPathUri+    , toNormalizedFilePath'+    , LSP.fromNormalizedFilePath+    , filePathToUri'+    , uriToFilePath'+    , readSrcSpan+    ) where++import Control.Applicative+import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))+import Control.Monad+import Data.Hashable (Hashable(hash))+import Data.String+import FastString+import qualified Language.Haskell.LSP.Types as LSP+import SrcLoc as GHC+import Text.ParserCombinators.ReadP as ReadP+import Data.Maybe (fromMaybe)++toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath+-- We want to keep empty paths instead of normalising them to "."+toNormalizedFilePath' "" = emptyFilePath+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp++emptyFilePath :: LSP.NormalizedFilePath+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""++-- | We use an empty string as a filepath when we don’t have a file.+-- However, haskell-lsp doesn’t support that in uriToFilePath and given+-- that it is not a valid filepath it does not make sense to upstream a fix.+-- So we have our own wrapper here that supports empty filepaths.+uriToFilePath' :: LSP.Uri -> Maybe FilePath+uriToFilePath' uri+    | uri == LSP.fromNormalizedUri emptyPathUri = Just ""+    | otherwise = LSP.uriToFilePath uri++emptyPathUri :: LSP.NormalizedUri+emptyPathUri =+    let s = "file://"+    in LSP.NormalizedUri (hash s) s++filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri+filePathToUri' = LSP.normalizedFilePathToUri++fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath++noFilePath :: FilePath+noFilePath = "<unknown>"++-- A dummy range to use when range is unknown+noRange :: Range+noRange =  Range (Position 0 0) (Position 1 0)++showPosition :: Position -> String+showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)++-- | Parser for the GHC output format+readSrcSpan :: ReadS RealSrcSpan+readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)+  where+    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan+    singleLineSrcSpanP = do+      fp <- filePathP+      l  <- readS_to_P reads <* char ':'+      c0 <- readS_to_P reads+      c1 <- (char '-' *> readS_to_P reads) <|> pure c0+      let from = mkRealSrcLoc fp l c0+          to   = mkRealSrcLoc fp l c1+      return $ mkRealSrcSpan from to++    multiLineSrcSpanP = do+      fp <- filePathP+      s <- parensP (srcLocP fp)+      void $ char '-'+      e <- parensP (srcLocP fp)+      return $ mkRealSrcSpan s e++    parensP :: ReadP a -> ReadP a+    parensP = between (char '(') (char ')')++    filePathP :: ReadP FastString+    filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""++    srcLocP :: FastString -> ReadP RealSrcLoc+    srcLocP fp = do+      l <- readS_to_P reads+      void $ char ','+      c <- readS_to_P reads+      return $ mkRealSrcLoc fp l c++    readFilePath :: ReadP FilePath+    readFilePath = some ReadP.get
src/Development/IDE/Types/Logger.hs view
@@ -1,54 +1,54 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE RankNTypes #-}
--- | This is a compatibility module that abstracts over the
--- concrete choice of logging framework so users can plug in whatever
--- framework they want to.
-module Development.IDE.Types.Logger
-  ( Priority(..)
-  , Logger(..)
-  , logError, logWarning, logInfo, logDebug, logTelemetry
-  , noLogging
-  ) where
-
-import qualified Data.Text as T
-
-
-data Priority
--- Don't change the ordering of this type or you will mess up the Ord
--- instance
-    = Telemetry -- ^ Events that are useful for gathering user metrics.
-    | Debug -- ^ Verbose debug logging.
-    | Info  -- ^ Useful information in case an error has to be understood.
-    | Warning
-      -- ^ These error messages should not occur in a expected usage, and
-      -- should be investigated.
-    | Error -- ^ Such log messages must never occur in expected usage.
-    deriving (Eq, Show, Ord, Enum, Bounded)
-
-
--- | Note that this is logging actions _of the program_, not of the user.
---   You shouldn't call warning/error if the user has caused an error, only
---   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).
-data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}
-
-
-logError :: Logger -> T.Text -> IO ()
-logError x = logPriority x Error
-
-logWarning :: Logger -> T.Text -> IO ()
-logWarning x = logPriority x Warning
-
-logInfo :: Logger -> T.Text -> IO ()
-logInfo x = logPriority x Info
-
-logDebug :: Logger -> T.Text -> IO ()
-logDebug x = logPriority x Debug
-
-logTelemetry :: Logger -> T.Text -> IO ()
-logTelemetry x = logPriority x Telemetry
-
-
-noLogging :: Logger
-noLogging = Logger $ \_ _ -> return ()
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE RankNTypes #-}+-- | This is a compatibility module that abstracts over the+-- concrete choice of logging framework so users can plug in whatever+-- framework they want to.+module Development.IDE.Types.Logger+  ( Priority(..)+  , Logger(..)+  , logError, logWarning, logInfo, logDebug, logTelemetry+  , noLogging+  ) where++import qualified Data.Text as T+++data Priority+-- Don't change the ordering of this type or you will mess up the Ord+-- instance+    = Telemetry -- ^ Events that are useful for gathering user metrics.+    | Debug -- ^ Verbose debug logging.+    | Info  -- ^ Useful information in case an error has to be understood.+    | Warning+      -- ^ These error messages should not occur in a expected usage, and+      -- should be investigated.+    | Error -- ^ Such log messages must never occur in expected usage.+    deriving (Eq, Show, Ord, Enum, Bounded)+++-- | Note that this is logging actions _of the program_, not of the user.+--   You shouldn't call warning/error if the user has caused an error, only+--   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).+data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}+++logError :: Logger -> T.Text -> IO ()+logError x = logPriority x Error++logWarning :: Logger -> T.Text -> IO ()+logWarning x = logPriority x Warning++logInfo :: Logger -> T.Text -> IO ()+logInfo x = logPriority x Info++logDebug :: Logger -> T.Text -> IO ()+logDebug x = logPriority x Debug++logTelemetry :: Logger -> T.Text -> IO ()+logTelemetry x = logPriority x Telemetry+++noLogging :: Logger+noLogging = Logger $ \_ _ -> return ()
src/Development/IDE/Types/Options.hs view
@@ -1,172 +1,172 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
--- | Options
-module Development.IDE.Types.Options
-  ( IdeOptions(..)
-  , IdePreprocessedSource(..)
-  , IdeReportProgress(..)
-  , IdeDefer(..)
-  , IdeTesting(..)
-  , IdeOTMemoryProfiling(..)
-  , clientSupportsProgress
-  , IdePkgLocationOptions(..)
-  , defaultIdeOptions
-  , IdeResult
-  , IdeGhcSession(..)
-  , OptHaddockParse(..)
-  ) where
-
-import Data.Default
-import Development.Shake
-import Development.IDE.GHC.Util
-import           GHC hiding (parseModule, typecheckModule)
-import           GhcPlugins                     as GHC hiding (fst3, (<>))
-import qualified Language.Haskell.LSP.Types.Capabilities as LSP
-import qualified Data.Text as T
-import Development.IDE.Types.Diagnostics
-import Control.DeepSeq (NFData(..))
-import Ide.Plugin.Config
-
-data IdeGhcSession = IdeGhcSession
-  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-  -- ^ Returns the Ghc session and the cradle dependencies
-  , sessionVersion :: !Int
-  -- ^ Used as Shake key, versions must be unique and not reused
-  }
-
-instance Show IdeGhcSession where show _ = "IdeGhcSession"
-instance NFData IdeGhcSession where rnf !_ = ()
-
-data IdeOptions = IdeOptions
-  { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
-    -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
-    --   and a list of errors, along with a new parse tree.
-  , optGhcSession :: Action IdeGhcSession
-    -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
-    --   For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
-    --   It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
-  , optPkgLocationOpts :: IdePkgLocationOptions
-    -- ^ How to locate source and @.hie@ files given a module name.
-  , optExtensions :: [String]
-    -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)
-
-  , optThreads :: Int
-    -- ^ Number of threads to use. Use 0 for number of threads on the machine.
-  , optShakeFiles :: Maybe FilePath
-  -- ^ Directory where the shake database should be stored. For ghcide this is always set to `Nothing` for now
-  -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
-  , optShakeProfiling :: Maybe FilePath
-    -- ^ Set to 'Just' to create a directory of profiling reports.
-  , optOTMemoryProfiling :: IdeOTMemoryProfiling
-    -- ^ Whether to record profiling information with OpenTelemetry. You must
-    --   also enable the -l RTS flag for this to have any effect
-  , optTesting :: IdeTesting
-    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
-  , optReportProgress :: IdeReportProgress
-    -- ^ Whether to report progress during long operations.
-  , optLanguageSyntax :: String
-    -- ^ the ```language to use
-  , optNewColonConvention :: Bool
-    -- ^ whether to use new colon convention
-  , optKeywords :: [T.Text]
-    -- ^ keywords used for completions. These are customizable
-    -- since DAML has a different set of keywords than Haskell.
-  , optDefer :: IdeDefer
-    -- ^ Whether to defer type errors, typed holes and out of scope
-    --   variables. Deferral allows the IDE to continue to provide
-    --   features such as diagnostics and go-to-definition, in
-    --   situations in which they would become unavailable because of
-    --   the presence of type errors, holes or unbound variables.
-  , optCheckProject :: !Bool
-    -- ^ Whether to typecheck the entire project on load
-  , optCheckParents :: CheckParents
-    -- ^ When to typecheck reverse dependencies of a file
-  , optHaddockParse :: OptHaddockParse
-    -- ^ Whether to return result of parsing module with Opt_Haddock.
-    --   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.
-  , optCustomDynFlags :: DynFlags -> DynFlags
-    -- ^ Will be called right after setting up a new cradle,
-    --   allowing to customize the Ghc options used
-  }
-
-data OptHaddockParse = HaddockParse | NoHaddockParse
-  deriving (Eq,Ord,Show,Enum)
-
-data IdePreprocessedSource = IdePreprocessedSource
-  { preprocWarnings :: [(GHC.SrcSpan, String)]
-    -- ^ Warnings emitted by the preprocessor.
-  , preprocErrors :: [(GHC.SrcSpan, String)]
-    -- ^ Errors emitted by the preprocessor.
-  , preprocSource :: GHC.ParsedSource
-    -- ^ New parse tree emitted by the preprocessor.
-  }
-
-newtype IdeReportProgress    = IdeReportProgress Bool
-newtype IdeDefer             = IdeDefer          Bool
-newtype IdeTesting           = IdeTesting        Bool
-newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool
-
-clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
-clientSupportsProgress caps = IdeReportProgress $ Just True ==
-    (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
-
-defaultIdeOptions :: Action IdeGhcSession -> IdeOptions
-defaultIdeOptions session = IdeOptions
-    {optPreprocessor = IdePreprocessedSource [] []
-    ,optGhcSession = session
-    ,optExtensions = ["hs", "lhs"]
-    ,optPkgLocationOpts = defaultIdePkgLocationOptions
-    ,optThreads = 0
-    ,optShakeFiles = Nothing
-    ,optShakeProfiling = Nothing
-    ,optOTMemoryProfiling = IdeOTMemoryProfiling False
-    ,optReportProgress = IdeReportProgress False
-    ,optLanguageSyntax = "haskell"
-    ,optNewColonConvention = False
-    ,optKeywords = haskellKeywords
-    ,optDefer = IdeDefer True
-    ,optTesting = IdeTesting False
-    ,optCheckProject = checkProject def
-    ,optCheckParents = checkParents def
-    ,optHaddockParse = HaddockParse
-    ,optCustomDynFlags = id
-    }
-
-
--- | The set of options used to locate files belonging to external packages.
-data IdePkgLocationOptions = IdePkgLocationOptions
-  { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath)
-  -- ^ Locate the HIE file for the given module. The PackageConfig can be
-  -- used to lookup settings like importDirs.
-  , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath)
-  -- ^ Locate the source file for the given module. The PackageConfig can be
-  -- used to lookup settings like importDirs. For DAML, we place them in the package DB.
-  -- For cabal this could point somewhere in ~/.cabal/packages.
-  }
-
-defaultIdePkgLocationOptions :: IdePkgLocationOptions
-defaultIdePkgLocationOptions = IdePkgLocationOptions f f
-    where f _ _ = return Nothing
-
--- | From https://wiki.haskell.org/Keywords
-haskellKeywords :: [T.Text]
-haskellKeywords =
-  [ "as"
-  , "case", "of"
-  , "class", "instance", "type"
-  , "data", "family", "newtype"
-  , "default"
-  , "deriving"
-  , "do", "mdo", "proc", "rec"
-  , "forall"
-  , "foreign"
-  , "hiding"
-  , "if", "then", "else"
-  , "import", "qualified", "hiding"
-  , "infix", "infixl", "infixr"
-  , "let", "in", "where"
-  , "module"
-  ]
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- | Options+module Development.IDE.Types.Options+  ( IdeOptions(..)+  , IdePreprocessedSource(..)+  , IdeReportProgress(..)+  , IdeDefer(..)+  , IdeTesting(..)+  , IdeOTMemoryProfiling(..)+  , clientSupportsProgress+  , IdePkgLocationOptions(..)+  , defaultIdeOptions+  , IdeResult+  , IdeGhcSession(..)+  , OptHaddockParse(..)+  ) where++import Data.Default+import Development.Shake+import Development.IDE.GHC.Util+import           GHC hiding (parseModule, typecheckModule)+import           GhcPlugins                     as GHC hiding (fst3, (<>))+import qualified Language.Haskell.LSP.Types.Capabilities as LSP+import qualified Data.Text as T+import Development.IDE.Types.Diagnostics+import Control.DeepSeq (NFData(..))+import Ide.Plugin.Config++data IdeGhcSession = IdeGhcSession+  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])+  -- ^ Returns the Ghc session and the cradle dependencies+  , sessionVersion :: !Int+  -- ^ Used as Shake key, versions must be unique and not reused+  }++instance Show IdeGhcSession where show _ = "IdeGhcSession"+instance NFData IdeGhcSession where rnf !_ = ()++data IdeOptions = IdeOptions+  { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource+    -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings+    --   and a list of errors, along with a new parse tree.+  , optGhcSession :: Action IdeGhcSession+    -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.+    --   For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.+    --   It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.+  , optPkgLocationOpts :: IdePkgLocationOptions+    -- ^ How to locate source and @.hie@ files given a module name.+  , optExtensions :: [String]+    -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@)++  , optThreads :: Int+    -- ^ Number of threads to use. Use 0 for number of threads on the machine.+  , optShakeFiles :: Maybe FilePath+  -- ^ Directory where the shake database should be stored. For ghcide this is always set to `Nothing` for now+  -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.+  , optShakeProfiling :: Maybe FilePath+    -- ^ Set to 'Just' to create a directory of profiling reports.+  , optOTMemoryProfiling :: IdeOTMemoryProfiling+    -- ^ Whether to record profiling information with OpenTelemetry. You must+    --   also enable the -l RTS flag for this to have any effect+  , optTesting :: IdeTesting+    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants+  , optReportProgress :: IdeReportProgress+    -- ^ Whether to report progress during long operations.+  , optLanguageSyntax :: String+    -- ^ the ```language to use+  , optNewColonConvention :: Bool+    -- ^ whether to use new colon convention+  , optKeywords :: [T.Text]+    -- ^ keywords used for completions. These are customizable+    -- since DAML has a different set of keywords than Haskell.+  , optDefer :: IdeDefer+    -- ^ Whether to defer type errors, typed holes and out of scope+    --   variables. Deferral allows the IDE to continue to provide+    --   features such as diagnostics and go-to-definition, in+    --   situations in which they would become unavailable because of+    --   the presence of type errors, holes or unbound variables.+  , optCheckProject :: !Bool+    -- ^ Whether to typecheck the entire project on load+  , optCheckParents :: CheckParents+    -- ^ When to typecheck reverse dependencies of a file+  , optHaddockParse :: OptHaddockParse+    -- ^ Whether to return result of parsing module with Opt_Haddock.+    --   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.+  , optCustomDynFlags :: DynFlags -> DynFlags+    -- ^ Will be called right after setting up a new cradle,+    --   allowing to customize the Ghc options used+  }++data OptHaddockParse = HaddockParse | NoHaddockParse+  deriving (Eq,Ord,Show,Enum)++data IdePreprocessedSource = IdePreprocessedSource+  { preprocWarnings :: [(GHC.SrcSpan, String)]+    -- ^ Warnings emitted by the preprocessor.+  , preprocErrors :: [(GHC.SrcSpan, String)]+    -- ^ Errors emitted by the preprocessor.+  , preprocSource :: GHC.ParsedSource+    -- ^ New parse tree emitted by the preprocessor.+  }++newtype IdeReportProgress    = IdeReportProgress Bool+newtype IdeDefer             = IdeDefer          Bool+newtype IdeTesting           = IdeTesting        Bool+newtype IdeOTMemoryProfiling = IdeOTMemoryProfiling    Bool++clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress+clientSupportsProgress caps = IdeReportProgress $ Just True ==+    (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))++defaultIdeOptions :: Action IdeGhcSession -> IdeOptions+defaultIdeOptions session = IdeOptions+    {optPreprocessor = IdePreprocessedSource [] []+    ,optGhcSession = session+    ,optExtensions = ["hs", "lhs"]+    ,optPkgLocationOpts = defaultIdePkgLocationOptions+    ,optThreads = 0+    ,optShakeFiles = Nothing+    ,optShakeProfiling = Nothing+    ,optOTMemoryProfiling = IdeOTMemoryProfiling False+    ,optReportProgress = IdeReportProgress False+    ,optLanguageSyntax = "haskell"+    ,optNewColonConvention = False+    ,optKeywords = haskellKeywords+    ,optDefer = IdeDefer True+    ,optTesting = IdeTesting False+    ,optCheckProject = checkProject def+    ,optCheckParents = checkParents def+    ,optHaddockParse = HaddockParse+    ,optCustomDynFlags = id+    }+++-- | The set of options used to locate files belonging to external packages.+data IdePkgLocationOptions = IdePkgLocationOptions+  { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath)+  -- ^ Locate the HIE file for the given module. The PackageConfig can be+  -- used to lookup settings like importDirs.+  , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath)+  -- ^ Locate the source file for the given module. The PackageConfig can be+  -- used to lookup settings like importDirs. For DAML, we place them in the package DB.+  -- For cabal this could point somewhere in ~/.cabal/packages.+  }++defaultIdePkgLocationOptions :: IdePkgLocationOptions+defaultIdePkgLocationOptions = IdePkgLocationOptions f f+    where f _ _ = return Nothing++-- | From https://wiki.haskell.org/Keywords+haskellKeywords :: [T.Text]+haskellKeywords =+  [ "as"+  , "case", "of"+  , "class", "instance", "type"+  , "data", "family", "newtype"+  , "default"+  , "deriving"+  , "do", "mdo", "proc", "rec"+  , "forall"+  , "foreign"+  , "hiding"+  , "if", "then", "else"+  , "import", "qualified", "hiding"+  , "infix", "infixl", "infixr"+  , "let", "in", "where"+  , "module"+  ]
src/Development/IDE/Types/Shake.hs view
@@ -1,41 +1,132 @@-{-# LANGUAGE ExistentialQuantification #-}
-module Development.IDE.Types.Shake (Value(..), Values, Key(..), currentValue) where
-
-import Control.DeepSeq
-import Data.Dynamic
-import Data.Hashable
-import Data.HashMap.Strict
-import Data.Typeable
-import GHC.Generics
-import Language.Haskell.LSP.Types
-
-data Value v
-    = Succeeded TextDocumentVersion v
-    | Stale TextDocumentVersion v
-    | Failed
-    deriving (Functor, Generic, Show)
-
-instance NFData v => NFData (Value v)
-
--- | Convert a Value to a Maybe. This will only return `Just` for
--- up2date results not for stale values.
-currentValue :: Value v -> Maybe v
-currentValue (Succeeded _ v) = Just v
-currentValue (Stale _ _) = Nothing
-currentValue Failed = Nothing
-
--- | The state of the all values.
-type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic)
-
--- | Key type
-data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
-
-instance Show Key where
-  show (Key k) = show k
-
-instance Eq Key where
-    Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
-                     | otherwise = False
-
-instance Hashable Key where
-    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module Development.IDE.Types.Shake+  ( Q (..),+    A (..),+    Value (..),+    ValueWithDiagnostics (..),+    Values,+    Key (..),+    BadDependency (..),+    ShakeValue(..),+    currentValue,+    isBadDependency,+  toShakeValue,encodeShakeValue,decodeShakeValue)+where++import Control.DeepSeq+import Control.Exception+import qualified Data.ByteString.Char8 as BS+import Data.Dynamic+import Data.Hashable+import Data.HashMap.Strict+import Data.Vector (Vector)+import Data.Typeable+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.Shake (RuleResult, ShakeException (shakeExceptionInner))+import Development.Shake.Classes+import GHC.Generics+import Language.Haskell.LSP.Types++data Value v+    = Succeeded TextDocumentVersion v+    | Stale TextDocumentVersion v+    | Failed+    deriving (Functor, Generic, Show)++instance NFData v => NFData (Value v)++-- | Convert a Value to a Maybe. This will only return `Just` for+-- up2date results not for stale values.+currentValue :: Value v -> Maybe v+currentValue (Succeeded _ v) = Just v+currentValue (Stale _ _) = Nothing+currentValue Failed = Nothing++data ValueWithDiagnostics+  = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic)++-- | The state of the all values and diagnostics+type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics++-- | Key type+data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k++instance Show Key where+  show (Key k) = show k++instance Eq Key where+    Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'+                     | otherwise = False++instance Hashable Key where+    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)++-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency+--   which short-circuits the rest of the action+newtype BadDependency = BadDependency String deriving Show+instance Exception BadDependency++isBadDependency :: SomeException -> Bool+isBadDependency x+    | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x+    | Just (_ :: BadDependency) <- fromException x = True+    | otherwise = False++newtype Q k = Q (k, NormalizedFilePath)+    deriving newtype (Eq, Hashable, NFData)++instance Binary k => Binary (Q k) where+    put (Q (k, fp)) = put (k, fp)+    get = do+        (k, fp) <- get+        -- The `get` implementation of NormalizedFilePath+        -- does not handle empty file paths so we+        -- need to handle this ourselves here.+        pure (Q (k, toNormalizedFilePath' fp))++instance Show k => Show (Q k) where+    show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file++-- | Invariant: the 'v' must be in normal form (fully evaluated).+--   Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database+newtype A v = A (Value v)+    deriving Show++instance NFData (A v) where rnf (A v) = v `seq` ()++-- In the Shake database we only store one type of key/result pairs,+-- namely Q (question) / A (answer).+type instance RuleResult (Q k) = A (RuleResult k)+++toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue+toShakeValue = maybe ShakeNoCutoff++data ShakeValue+  = -- | This is what we use when we get Nothing from+    -- a rule.+    ShakeNoCutoff+  | -- | This is used both for `Failed`+    -- as well as `Succeeded`.+    ShakeResult !BS.ByteString+  | ShakeStale !BS.ByteString+  deriving (Generic, Show)++instance NFData ShakeValue++encodeShakeValue :: ShakeValue -> BS.ByteString+encodeShakeValue = \case+  ShakeNoCutoff -> BS.empty+  ShakeResult r -> BS.cons 'r' r+  ShakeStale r -> BS.cons 's' r++decodeShakeValue :: BS.ByteString -> ShakeValue+decodeShakeValue bs = case BS.uncons bs of+  Nothing -> ShakeNoCutoff+  Just (x, xs)+    | x == 'r' -> ShakeResult xs+    | x == 's' -> ShakeStale xs+    | otherwise -> error $ "Failed to parse shake value " <> show bs
test/cabal/Development/IDE/Test/Runfiles.hs view
@@ -1,9 +1,9 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-module Development.IDE.Test.Runfiles
-  ( locateGhcideExecutable
-  ) where
-
-locateGhcideExecutable :: IO FilePath
-locateGhcideExecutable = pure "ghcide"
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.Test.Runfiles+  ( locateGhcideExecutable+  ) where++locateGhcideExecutable :: IO FilePath+locateGhcideExecutable = pure "ghcide"
test/data/hover/Bar.hs view
@@ -1,4 +1,4 @@-module Bar (Bar(..)) where
-
--- | Bar Haddock
-data Bar = Bar
+module Bar (Bar(..)) where++-- | Bar Haddock+data Bar = Bar
test/data/hover/Foo.hs view
@@ -1,6 +1,6 @@-module Foo (Bar, foo) where
-
-import Bar
-
--- | foo Haddock
-foo = Bar
+module Foo (Bar, foo) where++import Bar++-- | foo Haddock+foo = Bar
test/data/hover/GotoHover.hs view
@@ -1,60 +1,63 @@-{-# LANGUAGE OverloadedStrings #-}
-{- HLINT ignore -}
-module GotoHover ( module GotoHover) where
-import Data.Text (Text, pack)
-import Foo (Bar, foo)
-
-
-data TypeConstructor = DataConstructor
-  { fff :: Text
-  , ggg :: Int }
-aaa :: TypeConstructor
-aaa = DataConstructor
-  { fff = "dfgy"
-  , ggg = 832
-  }
-bbb :: TypeConstructor
-bbb = DataConstructor "mjgp" 2994
-ccc :: (Text, Int)
-ccc = (fff bbb, ggg aaa)
-ddd :: Num a => a -> a -> a
-ddd vv ww = vv +! ww
-a +! b = a - b
-hhh (Just a) (><) = a >< a
-iii a b = a `b` a
-jjj s = pack $ s <> s
-class MyClass a where
-  method :: a -> Int
-instance MyClass Int where
-  method = succ
-kkk :: MyClass a => Int -> a -> Int
-kkk n c = n + method c
-
-doBind :: Maybe ()
-doBind = do unwrapped <- Just ()
-            return unwrapped
-
-listCompBind :: [Char]
-listCompBind = [ succ c | c <- "ptfx" ]
-
-multipleClause :: Bool -> Char
-multipleClause True  =    't'
-multipleClause False = 'f'
-
--- | Recognizable docs: kpqz
-documented :: Monad m => Either Int (m a)
-documented = Left 7518
-
-listOfInt = [ 8391 :: Int, 6268 ]
-
-outer :: Bool
-outer = undefined inner where
-
-  inner :: Char
-  inner = undefined
-
-imported :: Bar
-imported = foo
-
-hole :: Int
-hole = _
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{- HLINT ignore -}+module GotoHover ( module GotoHover) where+import Data.Text (Text, pack)+import Foo (Bar, foo)+++data TypeConstructor = DataConstructor+  { fff :: Text+  , ggg :: Int }+aaa :: TypeConstructor+aaa = DataConstructor+  { fff = "dfgy"+  , ggg = 832+  }+bbb :: TypeConstructor+bbb = DataConstructor "mjgp" 2994+ccc :: (Text, Int)+ccc = (fff bbb, ggg aaa)+ddd :: Num a => a -> a -> a+ddd vv ww = vv +! ww+a +! b = a - b+hhh (Just a) (><) = a >< a+iii a b = a `b` a+jjj s = pack $ s <> s+class MyClass a where+  method :: a -> Int+instance MyClass Int where+  method = succ+kkk :: MyClass a => Int -> a -> Int+kkk n c = n + method c++doBind :: Maybe ()+doBind = do unwrapped <- Just ()+            return unwrapped++listCompBind :: [Char]+listCompBind = [ succ c | c <- "ptfx" ]++multipleClause :: Bool -> Char+multipleClause True  =    't'+multipleClause False = 'f'++-- | Recognizable docs: kpqz+documented :: Monad m => Either Int (m a)+documented = Left 7518++listOfInt = [ 8391 :: Int, 6268 ]++outer :: Bool+outer = undefined inner where++  inner :: Char+  inner = undefined++imported :: Bar+imported = foo++aa2 :: Bool+aa2 = $(id [| True |])++hole :: Int+hole = _
test/data/multi/a/A.hs view
@@ -1,3 +1,3 @@-module A(foo) where
-
-foo = ()
+module A(foo) where++foo = ()
test/data/multi/a/a.cabal view
@@ -1,9 +1,9 @@-name: a
-version: 1.0.0
-build-type: Simple
-cabal-version: >= 1.2
-
-library
-  build-depends: base
-  exposed-modules: A
-  hs-source-dirs: .
+name: a+version: 1.0.0+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base+  exposed-modules: A+  hs-source-dirs: .
test/data/multi/b/B.hs view
@@ -1,3 +1,3 @@-module B(module B) where
-import A
-qux = foo
+module B(module B) where+import A+qux = foo
test/data/multi/b/b.cabal view
@@ -1,9 +1,9 @@-name: b
-version: 1.0.0
-build-type: Simple
-cabal-version: >= 1.2
-
-library
-  build-depends: base, a
-  exposed-modules: B
-  hs-source-dirs: .
+name: b+version: 1.0.0+build-type: Simple+cabal-version: >= 1.2++library+  build-depends: base, a+  exposed-modules: B+  hs-source-dirs: .
test/data/multi/cabal.project view
@@ -1,1 +1,1 @@-packages: a b
+packages: a b
test/data/multi/hie.yaml view
@@ -1,6 +1,6 @@-cradle:
-  cabal:
-    - path: "./a"
-      component: "lib:a"
-    - path: "./b"
-      component: "lib:b"
+cradle:+  cabal:+    - path: "./a"+      component: "lib:a"+    - path: "./b"+      component: "lib:b"
test/exe/Main.hs view
@@ -1,4195 +1,4352 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE ImplicitParams  #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE CPP #-}
-#include "ghc-api-version.h"
-
-module Main (main) where
-
-import Control.Applicative.Combinators
-import Control.Exception (bracket_, catch)
-import qualified Control.Lens as Lens
-import Control.Monad
-import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (FromJSON, Value, toJSON)
-import qualified Data.Binary as Binary
-import Data.Default
-import Data.Foldable
-import Data.List.Extra
-import Data.Maybe
-import Data.Rope.UTF16 (Rope)
-import qualified Data.Rope.UTF16 as Rope
-import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe)
-import Development.IDE.Core.Shake (Q(..))
-import Development.IDE.GHC.Util
-import qualified Data.Text as T
-import Data.Typeable
-import Development.IDE.Spans.Common
-import Development.IDE.Test
-import Development.IDE.Test.Runfiles
-import qualified Development.IDE.Types.Diagnostics as Diagnostics
-import Development.IDE.Types.Location
-import Development.Shake (getDirectoryFilesIO)
-import Ide.Plugin.Config
-import qualified Experiments as Bench
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Capabilities
-import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
-import Language.Haskell.LSP.VFS (applyChange)
-import Network.URI
-import System.Environment.Blank (unsetEnv, getEnv, setEnv)
-import System.FilePath
-import System.IO.Extra hiding (withTempDir)
-import qualified System.IO.Extra
-import System.Directory
-import System.Exit (ExitCode(ExitSuccess))
-import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc)
-import System.Info.Extra (isWindows)
-import Test.QuickCheck
-import Test.QuickCheck.Instances ()
-import Test.Tasty
-import Test.Tasty.ExpectedFailure
-import Test.Tasty.Ingredients.Rerun
-import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
-import System.Time.Extra
-import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)
-import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir))
-import Control.Monad.Extra (whenJust)
-import qualified Language.Haskell.LSP.Types.Lens as L
-import Control.Lens ((^.))
-
-main :: IO ()
-main = do
-  -- We mess with env vars so run single-threaded.
-  defaultMainWithRerun $ testGroup "ghcide"
-    [ testSession "open close" $ do
-        doc <- createDoc "Testing.hs" "haskell" ""
-        void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
-        void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
-        closeDoc doc
-        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-    , initializeResponseTests
-    , completionTests
-    , cppTests
-    , diagnosticTests
-    , codeActionTests
-    , codeLensesTests
-    , outlineTests
-    , highlightTests
-    , findDefinitionAndHoverTests
-    , pluginSimpleTests
-    , pluginParsedResultTests
-    , preprocessorTests
-    , thTests
-    , safeTests
-    , unitTests
-    , haddockTests
-    , positionMappingTests
-    , watchedFilesTests
-    , cradleTests
-    , dependentFileTest
-    , nonLspCommandLine
-    , benchmarkTests
-    , ifaceTests
-    , bootTests
-    , rootUriTests
-    , asyncTests
-    , clientSettingsTest
-    , codeActionHelperFunctionTests
-    ]
-
-initializeResponseTests :: TestTree
-initializeResponseTests = withResource acquire release tests where
-
-  -- these tests document and monitor the evolution of the
-  -- capabilities announced by the server in the initialize
-  -- response. Currently the server advertises almost no capabilities
-  -- at all, in some cases failing to announce capabilities that it
-  -- actually does provide! Hopefully this will change ...
-  tests :: IO InitializeResponse -> TestTree
-  tests getInitializeResponse =
-    testGroup "initialize response capabilities"
-    [ chk "   text doc sync"             _textDocumentSync  tds
-    , chk "   hover"                         _hoverProvider (Just True)
-    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
-    , chk "NO signature help"        _signatureHelpProvider  Nothing
-    , chk "   goto definition"          _definitionProvider (Just True)
-    , chk "   goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True)
-    -- BUG in lsp-test, this test fails, just change the accepted response
-    -- for now
-    , chk "NO goto implementation"  _implementationProvider (Just $ GotoOptionsStatic True)
-    , chk "NO find references"          _referencesProvider  Nothing
-    , chk "   doc highlight"     _documentHighlightProvider  (Just True)
-    , chk "   doc symbol"           _documentSymbolProvider  (Just True)
-    , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing
-    , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True
-    , chk "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions Nothing
-    , chk "NO doc formatting"   _documentFormattingProvider  Nothing
-    , chk "NO doc range formatting"
-                           _documentRangeFormattingProvider  Nothing
-    , chk "NO doc formatting on typing"
-                          _documentOnTypeFormattingProvider  Nothing
-    , chk "NO renaming"                     _renameProvider (Just $ RenameOptionsStatic False)
-    , chk "NO doc link"               _documentLinkProvider  Nothing
-    , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)
-    , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
-    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
-    , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
-    , chk "NO experimental"                   _experimental  Nothing
-    ] where
-
-      tds = Just (TDSOptions (TextDocumentSyncOptions
-                              { _openClose = Just True
-                              , _change    = Just TdSyncIncremental
-                              , _willSave  = Nothing
-                              , _willSaveWaitUntil = Nothing
-                              , _save = Just (SaveOptions {_includeText = Nothing})}))
-
-      chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
-      chk title getActual expected =
-        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
-
-      che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
-      che title getActual _expected = testCase title doTest
-        where
-            doTest = do
-                ir <- getInitializeResponse
-                let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
-                True @=? T.isSuffixOf "typesignature.add" command
-
-
-  innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
-  innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
-  innerCaps  _ = error "this test only expects inner capabilities"
-
-  acquire :: IO InitializeResponse
-  acquire = run initializeResponse
-
-  release :: InitializeResponse -> IO ()
-  release = const $ pure ()
-
-
-diagnosticTests :: TestTree
-diagnosticTests = testGroup "diagnostics"
-  [ testSessionWait "fix syntax error" $ do
-      let content = T.unlines [ "module Testing wher" ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
-      let change = TextDocumentContentChangeEvent
-            { _range = Just (Range (Position 0 15) (Position 0 19))
-            , _rangeLength = Nothing
-            , _text = "where"
-            }
-      changeDoc doc [change]
-      expectDiagnostics [("Testing.hs", [])]
-  , testSessionWait "introduce syntax error" $ do
-      let content = T.unlines [ "module Testing where" ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
-      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
-      let change = TextDocumentContentChangeEvent
-            { _range = Just (Range (Position 0 15) (Position 0 18))
-            , _rangeLength = Nothing
-            , _text = "wher"
-            }
-      changeDoc doc [change]
-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
-  , testSessionWait "variable not in scope" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "foo :: Int -> Int -> Int"
-            , "foo a _b = a + ab"
-            , "bar :: Int -> Int -> Int"
-            , "bar _a b = cd + b"
-            ]
-      _ <- createDoc "Testing.hs" "haskell" content
-      expectDiagnostics
-        [ ( "Testing.hs"
-          , [ (DsError, (2, 15), "Variable not in scope: ab")
-            , (DsError, (4, 11), "Variable not in scope: cd")
-            ]
-          )
-        ]
-  , testSessionWait "type error" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "foo :: Int -> String -> Int"
-            , "foo a b = a + b"
-            ]
-      _ <- createDoc "Testing.hs" "haskell" content
-      expectDiagnostics
-        [ ( "Testing.hs"
-          , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
-          )
-        ]
-  , testSessionWait "typed hole" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "foo :: Int -> String"
-            , "foo a = _ a"
-            ]
-      _ <- createDoc "Testing.hs" "haskell" content
-      expectDiagnostics
-        [ ( "Testing.hs"
-          , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
-          )
-        ]
-
-  , testGroup "deferral" $
-    let sourceA a = T.unlines
-          [ "module A where"
-          , "a :: Int"
-          , "a = " <> a]
-        sourceB = T.unlines
-          [ "module B where"
-          , "import A ()"
-          , "b :: Float"
-          , "b = True"]
-        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"
-        expectedDs aMessage =
-          [ ("A.hs", [(DsError, (2,4), aMessage)])
-          , ("B.hs", [(DsError, (3,4), bMessage)])]
-        deferralTest title binding msg = testSessionWait title $ do
-          _ <- createDoc "A.hs" "haskell" $ sourceA binding
-          _ <- createDoc "B.hs" "haskell"   sourceB
-          expectDiagnostics $ expectedDs msg
-    in
-    [ deferralTest "type error"          "True"    "Couldn't match expected type"
-    , deferralTest "typed hole"          "_"       "Found hole"
-    , deferralTest "out of scope var"    "unbound" "Variable not in scope"
-    ]
-
-  , testSessionWait "remove required module" $ do
-      let contentA = T.unlines [ "module ModuleA where" ]
-      docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA"
-            ]
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      let change = TextDocumentContentChangeEvent
-            { _range = Just (Range (Position 0 0) (Position 0 20))
-            , _rangeLength = Nothing
-            , _text = ""
-            }
-      changeDoc docA [change]
-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]
-  , testSessionWait "add missing module" $ do
-      let contentB = T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA ()"
-            ]
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
-      let contentA = T.unlines [ "module ModuleA where" ]
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      expectDiagnostics [("ModuleB.hs", [])]
-  , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do
-      -- need to canonicalize in Mac Os
-      tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory
-      let contentB = T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA ()"
-            ]
-      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB
-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
-      let contentA = T.unlines [ "module ModuleA where" ]
-      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA
-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]
-  , testSessionWait "cyclic module dependency" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "import ModuleB"
-            ]
-      let contentB = T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA"
-            ]
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      expectDiagnostics
-        [ ( "ModuleA.hs"
-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
-          )
-        , ( "ModuleB.hs"
-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
-          )
-        ]
-  , testSessionWait "cyclic module dependency with hs-boot" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "import {-# SOURCE #-} ModuleB"
-            ]
-      let contentB = T.unlines
-            [ "{-# OPTIONS -Wmissing-signatures#-}"
-            , "module ModuleB where"
-            , "import ModuleA"
-            -- introduce an artificial diagnostic
-            , "foo = ()"
-            ]
-      let contentBboot = T.unlines
-            [ "module ModuleB where"
-            ]
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]
-  , testSessionWait "correct reference used with hs-boot" $ do
-      let contentB = T.unlines
-            [ "module ModuleB where"
-            , "import {-# SOURCE #-} ModuleA()"
-            ]
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "import ModuleB()"
-            , "x = 5"
-            ]
-      let contentAboot = T.unlines
-            [ "module ModuleA where"
-            ]
-      let contentC = T.unlines
-            [ "{-# OPTIONS -Wmissing-signatures #-}"
-            , "module ModuleC where"
-            , "import ModuleA"
-            -- this reference will fail if it gets incorrectly
-            -- resolved to the hs-boot file
-            , "y = x"
-            ]
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
-      _ <- createDoc "ModuleC.hs" "haskell" contentC
-      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]
-  , testSessionWait "redundant import" $ do
-      let contentA = T.unlines ["module ModuleA where"]
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA"
-            ]
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      expectDiagnosticsWithTags
-        [ ( "ModuleB.hs"
-          , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]
-          )
-        ]
-  , testSessionWait "redundant import even without warning" $ do
-      let contentA = T.unlines ["module ModuleA where"]
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"
-            , "module ModuleB where"
-            , "import ModuleA"
-            -- introduce an artificial warning for testing purposes
-            , "foo = ()"
-            ]
-      _ <- createDoc "ModuleA.hs" "haskell" contentA
-      _ <- createDoc "ModuleB.hs" "haskell" contentB
-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]
-  , testSessionWait "package imports" $ do
-      let thisDataListContent = T.unlines
-            [ "module Data.List where"
-            , "x :: Integer"
-            , "x = 123"
-            ]
-      let mainContent = T.unlines
-            [ "{-# LANGUAGE PackageImports #-}"
-            , "module Main where"
-            , "import qualified \"this\" Data.List as ThisList"
-            , "import qualified \"base\" Data.List as BaseList"
-            , "useThis = ThisList.x"
-            , "useBase = BaseList.map"
-            , "wrong1 = ThisList.map"
-            , "wrong2 = BaseList.x"
-            ]
-      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
-      _ <- createDoc "Main.hs" "haskell" mainContent
-      expectDiagnostics
-        [ ( "Main.hs"
-          , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
-            ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")
-            ]
-          )
-        ]
-  , testSessionWait "unqualified warnings" $ do
-      let fooContent = T.unlines
-            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
-            , "module Foo where"
-            , "foo :: Ord a => a -> Int"
-            , "foo _a = 1"
-            ]
-      _ <- createDoc "Foo.hs" "haskell" fooContent
-      expectDiagnostics
-        [ ( "Foo.hs"
-      -- The test is to make sure that warnings contain unqualified names
-      -- where appropriate. The warning should use an unqualified name 'Ord', not
-      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to
-      -- test this is fairly arbitrary.
-          , [(DsWarning, (2, 0), "Redundant constraint: Ord a")
-            ]
-          )
-        ]
-    , testSessionWait "lower-case drive" $ do
-          let aContent = T.unlines
-                [ "module A.A where"
-                , "import A.B ()"
-                ]
-              bContent = T.unlines
-                [ "{-# OPTIONS_GHC -Wall #-}"
-                , "module A.B where"
-                , "import Data.List"
-                ]
-          uriB <- getDocUri "A/B.hs"
-          Just pathB <- pure $ uriToFilePath uriB
-          uriB <- pure $
-              let (drive, suffix) = splitDrive pathB
-              in filePathToUri (joinDrive (lower drive) suffix)
-          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
-          liftIO $ writeFileUTF8 pathB $ T.unpack bContent
-          uriA <- getDocUri "A/A.hs"
-          Just pathA <- pure $ uriToFilePath uriA
-          uriA <- pure $
-              let (drive, suffix) = splitDrive pathA
-              in filePathToUri (joinDrive (lower drive) suffix)
-          let itemA = TextDocumentItem uriA "haskell" 0 aContent
-          let a = TextDocumentIdentifier uriA
-          sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
-          diagsNot <- skipManyTill anyMessage diagnostic
-          let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
-          -- Check that if we put a lower-case drive in for A.A
-          -- the diagnostics for A.B will also be lower-case.
-          liftIO $ fileUri @?= uriB
-          let msg = _message (head (toList diags) :: Diagnostic)
-          liftIO $ unless ("redundant" `T.isInfixOf` msg) $
-              assertFailure ("Expected redundant import but got " <> T.unpack msg)
-          closeDoc a
-  , testSessionWait "haddock parse error" $ do
-      let fooContent = T.unlines
-            [ "module Foo where"
-            , "foo :: Int"
-            , "foo = 1 {-|-}"
-            ]
-      _ <- createDoc "Foo.hs" "haskell" fooContent
-      expectDiagnostics
-        [ ( "Foo.hs"
-          , [(DsWarning, (2, 8), "Haddock parse error on input")
-            ]
-          )
-        ]
-  , testSessionWait "strip file path" $ do
-      let
-          name = "Testing"
-          content = T.unlines
-            [ "module " <> name <> " where"
-            , "value :: Maybe ()"
-            , "value = [()]"
-            ]
-      _ <- createDoc (T.unpack name <> ".hs") "haskell" content
-      notification <- skipManyTill anyMessage diagnostic
-      let
-          offenders =
-            Lsp.params .
-            Lsp.diagnostics .
-            Lens.folded .
-            Lsp.message .
-            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
-          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
-      Lens.mapMOf_ offenders failure notification
-  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do
-      liftIO $ writeFile (sessionDir </> "hie.yaml")
-        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"
-      let fooContent = T.unlines
-            [ "module Foo where"
-            , "foo = ()"
-            ]
-      _ <- createDoc "Foo.hs" "haskell" fooContent
-      expectDiagnostics
-        [ ( "Foo.hs"
-          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")
-            ]
-          )
-        ]
-  , testSessionWait "-Werror in pragma is ignored" $ do
-      let fooContent = T.unlines
-            [ "{-# OPTIONS_GHC -Wall -Werror #-}"
-            , "module Foo() where"
-            , "foo :: Int"
-            , "foo = 1"
-            ]
-      _ <- createDoc "Foo.hs" "haskell" fooContent
-      expectDiagnostics
-        [ ( "Foo.hs"
-          , [(DsWarning, (3, 0), "Defined but not used:")
-            ]
-          )
-        ]
-  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do
-    let bPath = dir </> "B.hs"
-        pPath = dir </> "P.hs"
-
-    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int
-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int
-
-    bdoc <- createDoc bPath "haskell" bSource
-    _pdoc <- createDoc pPath "haskell" pSource
-    expectDiagnostics
-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded
-
-    -- Change y from Int to B which introduces a type error in A (imported from P)
-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $
-                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]
-    expectDiagnostics
-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])
-      ]
-    expectNoMoreDiagnostics 2
-
-  , testSessionWait "deduplicate missing module diagnostics" $  do
-      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]
-      doc <- createDoc "Foo.hs" "haskell" fooContent
-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
-
-      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]
-      expectDiagnostics []
-
-      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
-            [ "module Foo() where" , "import MissingModule" ] ]
-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
-
-  , testGroup "Cancellation"
-    [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse  noTc
-    , cancellationTestGroup "edit import" editImport noDepends  noSession  yesParse noTc
-    , cancellationTestGroup "edit body"   editBody   yesDepends yesSession yesParse yesTc
-    ]
-  ]
-  where
-      editPair x y = let p = Position x y ; p' = Position x (y+2) in
-        (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}
-        ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})
-      editHeader = editPair 0 0
-      editImport = editPair 2 10
-      editBody   = editPair 3 10
-
-      noParse = False
-      yesParse = True
-
-      noDepends = False
-      yesDepends = True
-
-      noSession = False
-      yesSession = True
-
-      noTc = False
-      yesTc = True
-
-cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree
-cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name
-    [ cancellationTemplate edits Nothing
-    , cancellationTemplate edits $ Just ("GetFileContents", True)
-    , cancellationTemplate edits $ Just ("GhcSession", True)
-      -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!)
-    , cancellationTemplate edits $ Just ("GetModSummary", True)
-    , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)
-      -- getLocatedImports never fails
-    , cancellationTemplate edits $ Just ("GetLocatedImports", True)
-    , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome)
-    , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)
-    , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)
-    , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)
-    , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome)
-    ]
-
-cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree
-cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do
-      doc <- createDoc "Foo.hs" "haskell" $ T.unlines
-            [ "{-# OPTIONS_GHC -Wall #-}"
-            , "module Foo where"
-            , "import Data.List()"
-            , "f0 x = (x,x)"
-            ]
-
-      -- for the example above we expect one warning
-      let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ]
-      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags
-
-      -- Now we edit the document and wait for the given key (if any)
-      changeDoc doc [edit]
-      whenJust mbKey $ \(key, expectedResult) -> do
-        Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc
-        liftIO $ ideResultSuccess @?= expectedResult
-
-      -- The 2nd edit cancels the active session and unbreaks the file
-      -- wait for typecheck and check that the current diagnostics are accurate
-      changeDoc doc [undoEdit]
-      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags
-
-      expectNoMoreDiagnostics 0.5
-    where
-        -- similar to run except it disables kick
-        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s
-
-        typeCheck doc = do
-            Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
-            liftIO $ assertBool "The file should typecheck" ideResultSuccess
-            -- wait for the debouncer to publish diagnostics if the rule runs
-            liftIO $ sleep 0.2
-            -- flush messages to ensure current diagnostics state is updated
-            flushMessages
-
-codeActionTests :: TestTree
-codeActionTests = testGroup "code actions"
-  [ renameActionTests
-  , typeWildCardActionTests
-  , removeImportTests
-  , extendImportTests
-  , suggestImportTests
-  , fixConstructorImportTests
-  , importRenameActionTests
-  , fillTypedHoleTests
-  , addSigActionTests
-  , insertNewDefinitionTests
-  , deleteUnusedDefinitionTests
-  , addInstanceConstraintTests
-  , addFunctionConstraintTests
-  , removeRedundantConstraintsTests
-  , addTypeAnnotationsToLiteralsTest
-  , exportUnusedTests
-  ]
-
-codeActionHelperFunctionTests :: TestTree
-codeActionHelperFunctionTests = testGroup "code action helpers"
-    [
-    extendImportTestsRegEx
-    ]
-
-
-codeLensesTests :: TestTree
-codeLensesTests = testGroup "code lenses"
-  [ addSigLensesTests
-  ]
-
-watchedFilesTests :: TestTree
-watchedFilesTests = testGroup "watched files"
-  [ testSession' "workspace files" $ \sessionDir -> do
-      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"
-      _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
-      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
-
-      -- Expect 1 subscription: we only ever send one
-      liftIO $ length watchedFileRegs @?= 1
-
-  , testSession' "non workspace file" $ \sessionDir -> do
-      tmpDir <- liftIO getTemporaryDirectory
-      liftIO $ writeFile (sessionDir </> "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}")
-      _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
-      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
-
-      -- Expect 1 subscription: we only ever send one
-      liftIO $ length watchedFileRegs @?= 1
-
-  -- TODO add a test for didChangeWorkspaceFolder
-  ]
-
-renameActionTests :: TestTree
-renameActionTests = testGroup "rename actions"
-  [ testSession "change to local variable name" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "foo :: Int -> Int"
-            , "foo argName = argNme"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
-      executeCodeAction action
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "foo :: Int -> Int"
-            , "foo argName = argName"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "change to name of imported function" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "import Data.Maybe (maybeToList)"
-            , "foo :: Maybe a -> [a]"
-            , "foo = maybToList"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"
-      executeCodeAction action
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "import Data.Maybe (maybeToList)"
-            , "foo :: Maybe a -> [a]"
-            , "foo = maybeToList"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "suggest multiple local variable names" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "foo :: Char -> Char -> Char -> Char"
-            , "foo argument1 argument2 argument3 = argumentX"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
-                           ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
-      return()
-  , testSession "change infix function" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "monus :: Int -> Int"
-            , "monus x y = max 0 (x - y)"
-            , "foo x y = x `monnus` y"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
-      [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
-      executeCodeAction fixTypo
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "monus :: Int -> Int"
-            , "monus x y = max 0 (x - y)"
-            , "foo x y = x `monus` y"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  ]
-
-typeWildCardActionTests :: TestTree
-typeWildCardActionTests = testGroup "type wildcard actions"
-  [ testSession "global signature" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: _"
-            , "func x = x"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                   , "Use type signature" `T.isInfixOf` actionTitle
-                           ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: (p -> p)"
-            , "func x = x"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "multi-line message" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: _"
-            , "func x y = x + y"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                    , "Use type signature" `T.isInfixOf` actionTitle
-                              ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: (Integer -> Integer -> Integer)"
-            , "func x y = x + y"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "local signature" $ do
-      let content = T.unlines
-            [ "module Testing where"
-            , "func :: Int -> Int"
-            , "func x ="
-            , "  let y :: _"
-            , "      y = x * 2"
-            , "  in y"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
-                                    , "Use type signature" `T.isInfixOf` actionTitle
-                              ]
-      executeCodeAction addSignature
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "func :: Int -> Int"
-            , "func x ="
-            , "  let y :: (Int)"
-            , "      y = x * 2"
-            , "  in y"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  ]
-
-removeImportTests :: TestTree
-removeImportTests = testGroup "remove import actions"
-  [ testSession "redundant" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "qualified redundant" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import qualified ModuleA"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "redundant binding" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "stuffA = False"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            , "stuffC = ()"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
-            , "main = print stuffB"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (stuffB)"
-            , "main = print stuffB"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "redundant operator" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "a !! _b = a"
-            , "a <?> _b = a"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
-            , "main = print A.stuffB"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove !!, <?> from import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import qualified ModuleA as A (stuffB)"
-            , "main = print A.stuffB"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "redundant all import" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "data A = A"
-            , "stuffB :: Integer"
-            , "stuffB = 123"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (A(..), stuffB)"
-            , "main = print stuffB"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove A from import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (stuffB)"
-            , "main = print stuffB"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "redundant constructor import" $ do
-      let contentA = T.unlines
-            [ "module ModuleA where"
-            , "data D = A | B"
-            , "data E = F"
-            ]
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (D(A,B), E(F))"
-            , "main = B"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove A, E, F from import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import ModuleA (D(B))"
-            , "main = B"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "import containing the identifier Strict" $ do
-      let contentA = T.unlines
-            [ "module Strict where"
-            ]
-      _docA <- createDoc "Strict.hs" "haskell" contentA
-      let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            , "import Strict"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" contentB
-      _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }, _]
-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove import" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleB where"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  , testSession "remove all" $ do
-      let content = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleA where"
-            , "import Data.Function (fix, (&))"
-            , "import qualified Data.Functor.Const"
-            , "import Data.Functor.Identity"
-            , "import Data.Functor.Sum (Sum (InL, InR))"
-            , "import qualified Data.Kind as K (Constraint, Type)"
-            , "x = InL (Identity 123)"
-            , "y = fix id"
-            , "type T = K.Type"
-            ]
-      doc <- createDoc "ModuleC.hs" "haskell" content
-      _ <- waitForDiagnostics
-      [_, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }]
-          <- getCodeActions doc (Range (Position 2 0) (Position 2 5))
-      liftIO $ "Remove all redundant imports" @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"
-            , "module ModuleA where"
-            , "import Data.Function (fix)"
-            , "import Data.Functor.Identity"
-            , "import Data.Functor.Sum (Sum (InL))"
-            , "import qualified Data.Kind as K (Type)"
-            , "x = InL (Identity 123)"
-            , "y = fix id"
-            , "type T = K.Type"
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-  ]
-
-extendImportTests :: TestTree
-extendImportTests = testGroup "extend import actions"
-  [ testGroup "with checkAll" $ tests True
-  , testGroup "without checkAll" $ tests False
-  ]
-  where
-    tests overrideCheckProject =
-        [ testSession "extend single line import with value" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "stuffA :: Double"
-                    , "stuffA = 0.00750"
-                    , "stuffB :: Integer"
-                    , "stuffB = 123"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA as A (stuffB)"
-                    , "main = print (stuffA, stuffB)"
-                    ])
-            (Range (Position 3 17) (Position 3 18))
-            ["Add stuffA to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA as A (stuffA, stuffB)"
-                    , "main = print (stuffA, stuffB)"
-                    ])
-        , testSession "extend single line import with operator" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "(.*) :: Integer -> Integer -> Integer"
-                    , "x .* y = x * y"
-                    , "stuffB :: Integer"
-                    , "stuffB = 123"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA as A (stuffB)"
-                    , "main = print (stuffB .* stuffB)"
-                    ])
-            (Range (Position 3 17) (Position 3 18))
-            ["Add (.*) to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA as A ((.*), stuffB)"
-                    , "main = print (stuffB .* stuffB)"
-                    ])
-        , testSession "extend single line import with type" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "type A = Double"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA ()"
-                    , "b :: A"
-                    , "b = 0"
-                    ])
-            (Range (Position 2 5) (Position 2 5))
-            ["Add A to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (A)"
-                    , "b :: A"
-                    , "b = 0"
-                    ])
-        , testSession "extend single line import with constructor" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "data A = Constructor"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (A)"
-                    , "b :: A"
-                    , "b = Constructor"
-                    ])
-            (Range (Position 2 5) (Position 2 5))
-            ["Add A(Constructor) to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (A(Constructor))"
-                    , "b :: A"
-                    , "b = Constructor"
-                    ])
-        , testSession "extend single line import with mixed constructors" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "data A = ConstructorFoo | ConstructorBar"
-                    , "a = 1"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (A(ConstructorBar), a)"
-                    , "b :: A"
-                    , "b = ConstructorFoo"
-                    ])
-            (Range (Position 2 5) (Position 2 5))
-            ["Add A(ConstructorFoo) to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (A(ConstructorFoo, ConstructorBar), a)"
-                    , "b :: A"
-                    , "b = ConstructorFoo"
-                    ])
-        , testSession "extend single line qualified import with value" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "stuffA :: Double"
-                    , "stuffA = 0.00750"
-                    , "stuffB :: Integer"
-                    , "stuffB = 123"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import qualified ModuleA as A (stuffB)"
-                    , "main = print (A.stuffA, A.stuffB)"
-                    ])
-            (Range (Position 3 17) (Position 3 18))
-            ["Add stuffA to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import qualified ModuleA as A (stuffA, stuffB)"
-                    , "main = print (A.stuffA, A.stuffB)"
-                    ])
-        , testSession "extend multi line import with value" $ template
-            [("ModuleA.hs", T.unlines
-                    [ "module ModuleA where"
-                    , "stuffA :: Double"
-                    , "stuffA = 0.00750"
-                    , "stuffB :: Integer"
-                    , "stuffB = 123"
-                    ])]
-            ("ModuleB.hs", T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (stuffB"
-                    , "               )"
-                    , "main = print (stuffA, stuffB)"
-                    ])
-            (Range (Position 3 17) (Position 3 18))
-            ["Add stuffA to the import list of ModuleA"]
-            (T.unlines
-                    [ "module ModuleB where"
-                    , "import ModuleA (stuffA, stuffB"
-                    , "               )"
-                    , "main = print (stuffA, stuffB)"
-                    ])
-        , testSession "extend import list with multiple choices" $ template
-            [("ModuleA.hs", T.unlines
-                    --  this is just a dummy module to help the arguments needed for this test
-                    [  "module ModuleA (bar) where"
-                    , "bar = 10"
-                    ]),
-            ("ModuleB.hs", T.unlines
-                    --  this is just a dummy module to help the arguments needed for this test
-                    [  "module ModuleB (bar) where"
-                    , "bar = 10"
-                    ])]
-            ("ModuleC.hs", T.unlines
-                    [ "module ModuleC where"
-                    , "import ModuleB ()"
-                    , "import ModuleA ()"
-                    , "foo = bar"
-                    ])
-            (Range (Position 3 17) (Position 3 18))
-            ["Add bar to the import list of ModuleA",
-            "Add bar to the import list of ModuleB"]
-            (T.unlines
-                    [ "module ModuleC where"
-                    , "import ModuleB ()"
-                    , "import ModuleA (bar)"
-                    , "foo = bar"
-                    ])
-        ]
-      where
-        template setUpModules moduleUnderTest range expectedActions expectedContentB = do
-            sendNotification WorkspaceDidChangeConfiguration
-                (DidChangeConfigurationParams $ toJSON
-                  def{checkProject = overrideCheckProject})
-
-
-            mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules
-            docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)
-            _  <- waitForDiagnostics
-            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-            codeActions <- filter (\(CACodeAction CodeAction{_title=x}) -> T.isPrefixOf "Add" x)
-                <$>  getCodeActions docB range
-            let expectedTitles = (\(CACodeAction CodeAction{_title=x}) ->x) <$> codeActions
-            liftIO $ expectedActions @=? expectedTitles
-
-            -- Get the first action and execute the first action
-            let CACodeAction action :  _
-                        = sortOn (\(CACodeAction CodeAction{_title=x}) -> x) codeActions
-            executeCodeAction action
-            contentAfterAction <- documentContents docB
-            liftIO $ expectedContentB @=? contentAfterAction
-
-extendImportTestsRegEx :: TestTree
-extendImportTestsRegEx = testGroup "regex parsing"
-    [
-      testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing
-    , testCase "parse malformed import list" $ template
-                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"
-                  Nothing
-    , testCase "parse multiple imports" $ template
-                 "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"
-                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])
-    ]
-    where
-        template message expected = do
-            liftIO $ matchRegExMultipleImports message @=? expected
-
-
-
-suggestImportTests :: TestTree
-suggestImportTests = testGroup "suggest import actions"
-  [ testGroup "Dont want suggestion"
-    [ -- extend import
-      test False ["Data.List.NonEmpty ()"] "f = nonEmpty" []                "import Data.List.NonEmpty (nonEmpty)"
-      -- data constructor
-    , test False []                        "f = First"    []                "import Data.Monoid (First)"
-      -- internal module
-    , test False []         "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
-      -- package not in scope
-    , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"
-    ]
-  , testGroup "want suggestion"
-    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"
-    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"
-    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"
-    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"
-    , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"
-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"
-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"
-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"
-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"
-    , test True []          "f = First"                   []                "import Data.Monoid (First(First))"
-    , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"
-    , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"
-    , test True []          "f ExitSuccess = ()"          []                "import System.Exit (ExitCode(ExitSuccess))"
-    , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"
-    , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"
-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"
-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"
-    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"
-    , test True []          "f = empty"                   []                "import Control.Applicative"
-    , test True []          "f = (&)"                     []                "import Data.Function ((&))"
-    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"
-    , test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"
-    , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"
-    , test True []          "f = pack"                    []                "import Data.Text (pack)"
-    , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"
-    , test True []          "f = [] & id"                 []                "import Data.Function ((&))"
-    , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"
-    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"
-    ]
-  ]
-  where
-    test = test' False
-    wantWait = test' True True
-    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
-      let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
-          after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"
-      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
-      doc <- createDoc "Test.hs" "haskell" before
-      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-      _diags <- waitForDiagnostics
-      -- there isn't a good way to wait until the whole project is checked atm
-      when waitForCheckProject $ liftIO $ sleep 0.5
-      let defLine = length imps + 1
-          range = Range (Position defLine 0) (Position defLine maxBound)
-      actions <- getCodeActions doc range
-      if wanted
-         then do
-             action <- liftIO $ pickActionWithTitle newImp actions
-             executeCodeAction action
-             contentAfterAction <- documentContents doc
-             liftIO $ after @=? contentAfterAction
-          else
-              liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
-
-insertNewDefinitionTests :: TestTree
-insertNewDefinitionTests = testGroup "insert new definition actions"
-  [ testSession "insert new function definition" $ do
-      let txtB =
-            ["foo True = select [True]"
-            , ""
-            ,"foo False = False"
-            ]
-          txtB' =
-            [""
-            ,"someOtherCode = ()"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
-      _ <- waitForDiagnostics
-      CACodeAction action@CodeAction { _title = actionTitle } : _
-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
-                     getCodeActions docB (R 1 0 1 50)
-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      liftIO $ contentAfterAction @?= T.unlines (txtB ++
-        [ ""
-        , "select :: [Bool] -> Bool"
-        , "select = error \"not implemented\""
-        ]
-        ++ txtB')
-  , testSession "define a hole" $ do
-      let txtB =
-            ["foo True = _select [True]"
-            , ""
-            ,"foo False = False"
-            ]
-          txtB' =
-            [""
-            ,"someOtherCode = ()"
-            ]
-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
-      _ <- waitForDiagnostics
-      CACodeAction action@CodeAction { _title = actionTitle } : _
-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
-                     getCodeActions docB (R 1 0 1 50)
-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      liftIO $ contentAfterAction @?= T.unlines (
-        ["foo True = select [True]"
-        , ""
-        ,"foo False = False"
-        , ""
-        , "select :: [Bool] -> Bool"
-        , "select = error \"not implemented\""
-        ]
-        ++ txtB')
-  ]
-
-
-deleteUnusedDefinitionTests :: TestTree
-deleteUnusedDefinitionTests = testGroup "delete unused definition action"
-  [ testSession "delete unused top level binding" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-               , "module A (some) where"
-               , ""
-               , "f :: Int -> Int"
-               , "f 1 = let a = 1"
-               , "      in a"
-               , "f 2 = 2"
-               , ""
-               , "some = ()"
-               ])
-    (4, 0)
-    "Delete ‘f’"
-    (T.unlines [
-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-        , "module A (some) where"
-        , ""
-        , "some = ()"
-        ])
-
-  , testSession "delete unused top level binding defined in infix form" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-               , "module A (some) where"
-               , ""
-               , "myPlus :: Int -> Int -> Int"
-               , "a `myPlus` b = a + b"
-               , ""
-               , "some = ()"
-               ])
-    (4, 2)
-    "Delete ‘myPlus’"
-    (T.unlines [
-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-        , "module A (some) where"
-        , ""
-        , "some = ()"
-      ])
-  , testSession "delete unused binding in where clause" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (h, g) where"
-               , ""
-               , "h :: Int"
-               , "h = 3"
-               , ""
-               , "g :: Int"
-               , "g = 6"
-               , "  where"
-               , "    h :: Int"
-               , "    h = 4"
-               , ""
-               ])
-    (10, 4)
-    "Delete ‘h’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (h, g) where"
-               , ""
-               , "h :: Int"
-               , "h = 3"
-               , ""
-               , "g :: Int"
-               , "g = 6"
-               , "  where"
-               , ""
-               ])
-  , testSession "delete unused binding with multi-oneline signatures front" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (b, c) where"
-               , ""
-               , "a, b, c :: Int"
-               , "a = 3"
-               , "b = 4"
-               , "c = 5"
-               ])
-    (4, 0)
-    "Delete ‘a’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (b, c) where"
-               , ""
-               , "b, c :: Int"
-               , "b = 4"
-               , "c = 5"
-               ])
-  , testSession "delete unused binding with multi-oneline signatures mid" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (a, c) where"
-               , ""
-               , "a, b, c :: Int"
-               , "a = 3"
-               , "b = 4"
-               , "c = 5"
-               ])
-    (5, 0)
-    "Delete ‘b’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (a, c) where"
-               , ""
-               , "a, c :: Int"
-               , "a = 3"
-               , "c = 5"
-               ])
-  , testSession "delete unused binding with multi-oneline signatures end" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (a, b) where"
-               , ""
-               , "a, b, c :: Int"
-               , "a = 3"
-               , "b = 4"
-               , "c = 5"
-               ])
-    (6, 0)
-    "Delete ‘c’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"
-               , "module A (a, b) where"
-               , ""
-               , "a, b :: Int"
-               , "a = 3"
-               , "b = 4"
-               ])
-  ]
-  where
-    testFor source pos expectedTitle expectedResult = do
-      docId <- createDoc "A.hs" "haskell" source
-      expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ]
-
-      (action, title) <- extractCodeAction docId "Delete"
-
-      liftIO $ title @?= expectedTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docId
-      liftIO $ contentAfterAction @?= expectedResult
-
-    extractCodeAction docId actionPrefix = do
-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]
-      return (action, actionTitle)
-
-addTypeAnnotationsToLiteralsTest :: TestTree
-addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints"
-  [
-    testSession "add default type to satisfy one contraint" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "module A (f) where"
-               , ""
-               , "f = 1"
-               ])
-    [ (DsWarning, (3, 4), "Defaulting the following constraint") ]
-    "Add type annotation ‘Integer’ to ‘1’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "module A (f) where"
-               , ""
-               , "f = (1 :: Integer)"
-               ])
-
-  , testSession "add default type to satisfy one contraint with duplicate literals" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f = seq \"debug\" traceShow \"debug\""
-               ])
-    [ (DsWarning, (6, 8), "Defaulting the following constraint")
-    , (DsWarning, (6, 16), "Defaulting the following constraint")
-    ]
-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f = seq (\"debug\" :: [Char]) traceShow \"debug\""
-               ])
-  , testSession "add default type to satisfy two contraints" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f a = traceShow \"debug\" a"
-               ])
-    [ (DsWarning, (6, 6), "Defaulting the following constraint") ]
-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f a = traceShow (\"debug\" :: [Char]) a"
-               ])
-  , testSession "add default type to satisfy two contraints with duplicate literals" $
-    testFor
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"
-               ])
-    [ (DsWarning, (6, 54), "Defaulting the following constraint") ]
-    "Add type annotation ‘[Char]’ to ‘\"debug\"’"
-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"
-               , "{-# LANGUAGE OverloadedStrings #-}"
-               , "module A (f) where"
-               , ""
-               , "import Debug.Trace"
-               , ""
-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))"
-               ])
-  ]
-  where
-    testFor source diag expectedTitle expectedResult = do
-      docId <- createDoc "A.hs" "haskell" source
-      expectDiagnostics [ ("A.hs", diag) ]
-
-      (action, title) <- extractCodeAction docId "Add type annotation"
-
-      liftIO $ title @?= expectedTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docId
-      liftIO $ contentAfterAction @?= expectedResult
-
-    extractCodeAction docId actionPrefix = do
-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]
-      return (action, actionTitle)
-
-
-fixConstructorImportTests :: TestTree
-fixConstructorImportTests = testGroup "fix import actions"
-  [ testSession "fix constructor import" $ template
-      (T.unlines
-            [ "module ModuleA where"
-            , "data A = Constructor"
-            ])
-      (T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA(Constructor)"
-            ])
-      (Range (Position 1 10) (Position 1 11))
-      "Fix import of A(Constructor)"
-      (T.unlines
-            [ "module ModuleB where"
-            , "import ModuleA(A(Constructor))"
-            ])
-  ]
-  where
-    template contentA contentB range expectedAction expectedContentB = do
-      _docA <- createDoc "ModuleA.hs" "haskell" contentA
-      docB  <- createDoc "ModuleB.hs" "haskell" contentB
-      _diags <- waitForDiagnostics
-      CACodeAction action@CodeAction { _title = actionTitle } : _
-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
-                     getCodeActions docB range
-      liftIO $ expectedAction @=? actionTitle
-      executeCodeAction action
-      contentAfterAction <- documentContents docB
-      liftIO $ expectedContentB @=? contentAfterAction
-
-importRenameActionTests :: TestTree
-importRenameActionTests = testGroup "import rename actions"
-  [ testSession "Data.Mape -> Data.Map"   $ check "Map"
-  , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where
-  check modname = do
-      let content = T.unlines
-            [ "module Testing where"
-            , "import Data.Mape"
-            ]
-      doc <- createDoc "Testing.hs" "haskell" content
-      _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
-      let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
-      executeCodeAction changeToMap
-      contentAfterAction <- documentContents doc
-      let expectedContentAfterAction = T.unlines
-            [ "module Testing where"
-            , "import Data." <> modname
-            ]
-      liftIO $ expectedContentAfterAction @=? contentAfterAction
-
-fillTypedHoleTests :: TestTree
-fillTypedHoleTests = let
-
-  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text
-  sourceCode a b c = T.unlines
-    [ "module Testing where"
-      , ""
-      , "globalConvert :: Int -> String"
-      , "globalConvert = undefined"
-      , ""
-      , "globalInt :: Int"
-      , "globalInt = 3"
-      , ""
-      , "bar :: Int -> Int -> String"
-      , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"
-      , "  localConvert = (flip replicate) 'x'"
-      , ""
-      , "foo :: () -> Int -> String"
-      , "foo = undefined"
-
-    ]
-
-  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree
-  check actionTitle
-        oldA oldB oldC
-        newA newB newC = testSession (T.unpack actionTitle) $ do
-    let originalCode = sourceCode oldA oldB oldC
-    let expectedCode = sourceCode newA newB newC
-    doc <- createDoc "Testing.hs" "haskell" originalCode
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
-    executeCodeAction chosenAction
-    modifiedCode <- documentContents doc
-    liftIO $ expectedCode @=? modifiedCode
-  in
-  testGroup "fill typed holes"
-  [ check "replace _ with show"
-          "_"    "n" "n"
-          "show" "n" "n"
-
-  , check "replace _ with globalConvert"
-          "_"             "n" "n"
-          "globalConvert" "n" "n"
-
-  , check "replace _convertme with localConvert"
-          "_convertme"   "n" "n"
-          "localConvert" "n" "n"
-
-  , check "replace _b with globalInt"
-          "_a" "_b"        "_c"
-          "_a" "globalInt" "_c"
-
-  , check "replace _c with globalInt"
-          "_a" "_b"        "_c"
-          "_a" "_b" "globalInt"
-
-  , check "replace _c with parameterInt"
-          "_a" "_b" "_c"
-          "_a" "_b"  "parameterInt"
-  , check "replace _ with foo _"
-          "_" "n" "n"
-          "(foo _)" "n" "n"
-  , testSession "replace _toException with E.toException" $ do
-      let mkDoc x = T.unlines
-            [ "module Testing where"
-            , "import qualified Control.Exception as E"
-            , "ioToSome :: E.IOException -> E.SomeException"
-            , "ioToSome = " <> x ]
-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"
-      _ <- waitForDiagnostics
-      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))
-      chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions
-      executeCodeAction chosen
-      modifiedCode <- documentContents doc
-      liftIO $ mkDoc "E.toException" @=? modifiedCode
-  ]
-
-addInstanceConstraintTests :: TestTree
-addInstanceConstraintTests = let
-  missingConstraintSourceCode :: Maybe T.Text -> T.Text
-  missingConstraintSourceCode mConstraint =
-    let constraint = maybe "" (<> " => ") mConstraint
-     in T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Wrap a = Wrap a"
-    , ""
-    , "instance " <> constraint <> "Eq (Wrap a) where"
-    , "  (Wrap x) == (Wrap y) = x == y"
-    ]
-
-  incompleteConstraintSourceCode :: Maybe T.Text -> T.Text
-  incompleteConstraintSourceCode mConstraint =
-    let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")")  mConstraint
-     in T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Pair a b = Pair a b"
-    , ""
-    , "instance " <> constraint <> " => Eq (Pair a b) where"
-    , "  (Pair x y) == (Pair x' y') = x == x' && y == y'"
-    ]
-
-  incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text
-  incompleteConstraintSourceCode2 mConstraint =
-    let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")")  mConstraint
-     in T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Three a b c = Three a b c"
-    , ""
-    , "instance " <> constraint <> " => Eq (Three a b c) where"
-    , "  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"
-    ]
-
-  check :: T.Text -> T.Text -> T.Text -> TestTree
-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do
-    doc <- createDoc "Testing.hs" "haskell" originalCode
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68))
-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
-    executeCodeAction chosenAction
-    modifiedCode <- documentContents doc
-    liftIO $ expectedCode @=? modifiedCode
-
-  in testGroup "add instance constraint"
-  [ check
-    "Add `Eq a` to the context of the instance declaration"
-    (missingConstraintSourceCode Nothing)
-    (missingConstraintSourceCode $ Just "Eq a")
-  , check
-    "Add `Eq b` to the context of the instance declaration"
-    (incompleteConstraintSourceCode Nothing)
-    (incompleteConstraintSourceCode $ Just "Eq b")
-  , check
-    "Add `Eq c` to the context of the instance declaration"
-    (incompleteConstraintSourceCode2 Nothing)
-    (incompleteConstraintSourceCode2 $ Just "Eq c")
-  ]
-
-addFunctionConstraintTests :: TestTree
-addFunctionConstraintTests = let
-  missingConstraintSourceCode :: T.Text -> T.Text
-  missingConstraintSourceCode constraint =
-    T.unlines
-    [ "module Testing where"
-    , ""
-    , "eq :: " <> constraint <> "a -> a -> Bool"
-    , "eq x y = x == y"
-    ]
-
-  incompleteConstraintSourceCode :: T.Text -> T.Text
-  incompleteConstraintSourceCode constraint =
-    T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Pair a b = Pair a b"
-    , ""
-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"
-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"
-    ]
-
-  incompleteConstraintSourceCode2 :: T.Text -> T.Text
-  incompleteConstraintSourceCode2 constraint =
-    T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Three a b c = Three a b c"
-    , ""
-    , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"
-    , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"
-    ]
-
-  incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text
-  incompleteConstraintSourceCodeWithExtraCharsInContext constraint =
-    T.unlines
-    [ "module Testing where"
-    , ""
-    , "data Pair a b = Pair a b"
-    , ""
-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"
-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"
-    ]
-
-  incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text
-  incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint =
-    T.unlines
-    [ "module Testing where"
-    , "data Pair a b = Pair a b"
-    , "eq "
-    , "    :: " <> constraint
-    , "    => Pair a b -> Pair a b -> Bool"
-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"
-    ]
-
-  check :: T.Text -> T.Text -> T.Text -> TestTree
-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do
-    doc <- createDoc "Testing.hs" "haskell" originalCode
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound))
-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
-    executeCodeAction chosenAction
-    modifiedCode <- documentContents doc
-    liftIO $ expectedCode @=? modifiedCode
-
-  in testGroup "add function constraint"
-  [ check
-    "Add `Eq a` to the context of the type signature for `eq`"
-    (missingConstraintSourceCode "")
-    (missingConstraintSourceCode "Eq a => ")
-  , check
-    "Add `Eq b` to the context of the type signature for `eq`"
-    (incompleteConstraintSourceCode "Eq a")
-    (incompleteConstraintSourceCode "(Eq a, Eq b)")
-  , check
-    "Add `Eq c` to the context of the type signature for `eq`"
-    (incompleteConstraintSourceCode2 "(Eq a, Eq b)")
-    (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)")
-  , check
-    "Add `Eq b` to the context of the type signature for `eq`"
-    (incompleteConstraintSourceCodeWithExtraCharsInContext "( Eq a )")
-    (incompleteConstraintSourceCodeWithExtraCharsInContext "(Eq a, Eq b)")
-  , check
-    "Add `Eq b` to the context of the type signature for `eq`"
-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a)")
-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a, Eq b)")
-  ]
-
-removeRedundantConstraintsTests :: TestTree
-removeRedundantConstraintsTests = let
-  header =
-    [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"
-    , "module Testing where"
-    , ""
-    ]
-
-  redundantConstraintsCode :: Maybe T.Text -> T.Text
-  redundantConstraintsCode mConstraint =
-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint
-      in T.unlines $ header <>
-        [ "foo :: " <> constraint <> "a -> a"
-        , "foo = id"
-        ]
-
-  redundantMixedConstraintsCode :: Maybe T.Text -> T.Text
-  redundantMixedConstraintsCode mConstraint =
-    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint
-      in T.unlines $ header <>
-        [ "foo :: " <> constraint <> " => a -> Bool"
-        , "foo x = x == 1"
-        ]
-
-  typeSignatureSpaces :: T.Text
-  typeSignatureSpaces = T.unlines $ header <>
-    [ "foo ::  (Num a, Eq a, Monoid a)  => a -> Bool"
-    , "foo x = x == 1"
-    ]
-
-  typeSignatureMultipleLines :: T.Text
-  typeSignatureMultipleLines = T.unlines $ header <>
-    [ "foo :: (Num a, Eq a, Monoid a)"
-    , "=> a -> Bool"
-    , "foo x = x == 1"
-    ]
-
-  check :: T.Text -> T.Text -> T.Text -> TestTree
-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do
-    doc <- createDoc "Testing.hs" "haskell" originalCode
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound))
-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
-    executeCodeAction chosenAction
-    modifiedCode <- documentContents doc
-    liftIO $ expectedCode @=? modifiedCode
-
-  checkPeculiarFormatting :: String -> T.Text -> TestTree
-  checkPeculiarFormatting title code = testSession title $ do
-    doc <- createDoc "Testing.hs" "haskell" code
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound))
-    liftIO $ assertBool "Found some actions" (null actionsOrCommands)
-
-  in testGroup "remove redundant function constraints"
-  [ check
-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"
-    (redundantConstraintsCode $ Just "Eq a")
-    (redundantConstraintsCode Nothing)
-  , check
-    "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`"
-    (redundantConstraintsCode $ Just "(Eq a, Monoid a)")
-    (redundantConstraintsCode Nothing)
-  , check
-    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"
-    (redundantMixedConstraintsCode $ Just "Monoid a, Show a")
-    (redundantMixedConstraintsCode Nothing)
-  , checkPeculiarFormatting
-    "should do nothing when constraints contain an arbitrary number of spaces"
-    typeSignatureSpaces
-  , checkPeculiarFormatting
-    "should do nothing when constraints contain line feeds"
-    typeSignatureMultipleLines
-  ]
-
-addSigActionTests :: TestTree
-addSigActionTests = let
-  header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
-  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
-  before def     = T.unlines [header, moduleH,      def]
-  after' def sig = T.unlines [header, moduleH, sig, def]
-
-  def >:: sig = testSession (T.unpack def) $ do
-    let originalCode = before def
-    let expectedCode = after' def sig
-    doc <- createDoc "Sigs.hs" "haskell" originalCode
-    _ <- waitForDiagnostics
-    actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
-    chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
-    executeCodeAction chosenAction
-    modifiedCode <- documentContents doc
-    liftIO $ expectedCode @=? modifiedCode
-  in
-  testGroup "add signature"
-    [ "abc = True"              >:: "abc :: Bool"
-    , "foo a b = a + b"         >:: "foo :: Num a => a -> a -> a"
-    , "bar a b = show $ a + b"  >:: "bar :: (Show a, Num a) => a -> a -> String"
-    , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"
-    , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"
-    , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"
-    , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
-    ]
-
-exportUnusedTests :: TestTree
-exportUnusedTests = testGroup "export unused actions"
-  [ testGroup "don't want suggestion"
-    [ testSession "implicit exports" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# OPTIONS_GHC -Wmissing-signatures #-}"
-              , "module A where"
-              , "foo = id"])
-        (R 3 0 3 3)
-        "Export ‘foo’"
-        Nothing -- codeaction should not be available
-    , testSession "not top-level" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# OPTIONS_GHC -Wunused-binds #-}"
-              , "module A (foo,bar) where"
-              , "foo = ()"
-              , "  where bar = ()"
-              , "bar = ()"])
-        (R 2 0 2 11)
-        "Export ‘bar’"
-        Nothing
-    , testSession "type is exported but not the constructor of same name" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo) where"
-              , "data Foo = Foo"])
-        (R 2 0 2 8)
-        "Export ‘Foo’"
-        Nothing -- codeaction should not be available
-    , testSession "unused data field" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo(Foo)) where"
-              , "data Foo = Foo {foo :: ()}"])
-        (R 2 0 2 20)
-        "Export ‘foo’"
-        Nothing -- codeaction should not be available
-    ]
-  , testGroup "want suggestion"
-    [ testSession "empty exports" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A ("
-              , ") where"
-              , "foo = id"])
-        (R 3 0 3 3)
-        "Export ‘foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A ("
-              , "foo) where"
-              , "foo = id"])
-    , testSession "single line explicit exports" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (foo) where"
-              , "foo = id"
-              , "bar = foo"])
-        (R 3 0 3 3)
-        "Export ‘bar’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (foo,bar) where"
-              , "foo = id"
-              , "bar = foo"])
-    , testSession "multi line explicit exports" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A"
-              , "  ("
-              , "    foo) where"
-              , "foo = id"
-              , "bar = foo"])
-        (R 5 0 5 3)
-        "Export ‘bar’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A"
-              , "  ("
-              , "    foo,bar) where"
-              , "foo = id"
-              , "bar = foo"])
-    , testSession "export list ends in comma" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A"
-              , "  (foo,"
-              , "  ) where"
-              , "foo = id"
-              , "bar = foo"])
-        (R 4 0 4 3)
-        "Export ‘bar’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A"
-              , "  (foo,"
-              , "  bar) where"
-              , "foo = id"
-              , "bar = foo"])
-    , testSession "unused pattern synonym" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE PatternSynonyms #-}"
-              , "module A () where"
-              , "pattern Foo a <- (a, _)"])
-        (R 3 0 3 10)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE PatternSynonyms #-}"
-              , "module A (pattern Foo) where"
-              , "pattern Foo a <- (a, _)"])
-    , testSession "unused data type" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "data Foo = Foo"])
-        (R 2 0 2 7)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo(..)) where"
-              , "data Foo = Foo"])
-    , testSession "unused newtype" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "newtype Foo = Foo ()"])
-        (R 2 0 2 10)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo(..)) where"
-              , "newtype Foo = Foo ()"])
-    , testSession "unused type synonym" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "type Foo = ()"])
-        (R 2 0 2 7)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo) where"
-              , "type Foo = ()"])
-    , testSession "unused type family" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeFamilies #-}"
-              , "module A () where"
-              , "type family Foo p"])
-        (R 3 0 3 15)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeFamilies #-}"
-              , "module A (Foo(..)) where"
-              , "type family Foo p"])
-    , testSession "unused typeclass" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "class Foo a"])
-        (R 2 0 2 8)
-        "Export ‘Foo’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (Foo(..)) where"
-              , "class Foo a"])
-    , testSession "infix" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "a `f` b = ()"])
-        (R 2 0 2 11)
-        "Export ‘f’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A (f) where"
-              , "a `f` b = ()"])
-   , testSession "function operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A () where"
-              , "(<|) = ($)"])
-        (R 2 0 2 9)
-        "Export ‘<|’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "module A ((<|)) where"
-              , "(<|) = ($)"])
-    , testSession "type synonym operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A () where"
-              , "type (:<) = ()"])
-        (R 3 0 3 13)
-        "Export ‘:<’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A ((:<)) where"
-              , "type (:<) = ()"])
-    , testSession "type family operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeFamilies #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A () where"
-              , "type family (:<)"])
-        (R 4 0 4 15)
-        "Export ‘:<’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeFamilies #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A (type (:<)(..)) where"
-              , "type family (:<)"])
-    , testSession "typeclass operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A () where"
-              , "class (:<) a"])
-        (R 3 0 3 11)
-        "Export ‘:<’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A (type (:<)(..)) where"
-              , "class (:<) a"])
-    , testSession "newtype operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A () where"
-              , "newtype (:<) = Foo ()"])
-        (R 3 0 3 20)
-        "Export ‘:<’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A (type (:<)(..)) where"
-              , "newtype (:<) = Foo ()"])
-    , testSession "data type operator" $ template
-        (T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A () where"
-              , "data (:<) = Foo ()"])
-        (R 3 0 3 17)
-        "Export ‘:<’"
-        (Just $ T.unlines
-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"
-              , "{-# LANGUAGE TypeOperators #-}"
-              , "module A (type (:<)(..)) where"
-              , "data (:<) = Foo ()"])
-    ]
-  ]
-    where
-      template initialContent range expectedAction expectedContents = do
-        doc <- createDoc "A.hs" "haskell" initialContent
-        _ <- waitForDiagnostics
-        actions <- getCodeActions doc range
-        case expectedContents of
-          Just content -> do
-            action <- liftIO $ pickActionWithTitle expectedAction actions
-            executeCodeAction action
-            contentAfterAction <- documentContents doc
-            liftIO $ content @=? contentAfterAction
-          Nothing ->
-            liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= []
-
-addSigLensesTests :: TestTree
-addSigLensesTests = let
-  missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
-  notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
-  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C"
-  other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
-  before  withMissing def
-    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
-  after'  withMissing def sig
-    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
-
-  sigSession withMissing def sig = testSession (T.unpack def) $ do
-    let originalCode = before withMissing def
-    let expectedCode = after' withMissing def sig
-    doc <- createDoc "Sigs.hs" "haskell" originalCode
-    [CodeLens {_command = Just c}] <- getCodeLenses doc
-    executeCommand c
-    modifiedCode <- getDocumentEdit doc
-    liftIO $ expectedCode @=? modifiedCode
-  in
-  testGroup "add signature"
-    [ testGroup title
-      [ sigSession enableWarnings "abc = True"              "abc :: Bool"
-      , sigSession enableWarnings "foo a b = a + b"         "foo :: Num a => a -> a -> a"
-      , sigSession enableWarnings "bar a b = show $ a + b"  "bar :: (Show a, Num a) => a -> a -> String"
-      , sigSession enableWarnings "(!!!) a b = a > b"       "(!!!) :: Ord a => a -> a -> Bool"
-      , sigSession enableWarnings "a >>>> b = a + b"        "(>>>>) :: Num a => a -> a -> a"
-      , sigSession enableWarnings "a `haha` b = a b"        "haha :: (t1 -> t2) -> t1 -> t2"
-      , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
-      , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a"
-      ]
-      | (title, enableWarnings) <-
-        [("with warnings enabled", True)
-        ,("with warnings disabled", False)
-        ]
-    ]
-
-checkDefs :: [Location] -> Session [Expect] -> Session ()
-checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
-
-  check (ExpectRange expectedRange) = do
-    assertNDefinitionsFound 1 defs
-    assertRangeCorrect (head defs) expectedRange
-  check (ExpectLocation expectedLocation) = do
-    assertNDefinitionsFound 1 defs
-    liftIO $ do
-      canonActualLoc <- canonicalizeLocation (head defs)
-      canonExpectedLoc <- canonicalizeLocation expectedLocation
-      canonActualLoc @?= canonExpectedLoc
-  check ExpectNoDefinitions = do
-    assertNDefinitionsFound 0 defs
-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
-  check _ = pure () -- all other expectations not relevant to getDefinition
-
-  assertNDefinitionsFound :: Int -> [a] -> Session ()
-  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
-
-  assertRangeCorrect Location{_range = foundRange} expectedRange =
-    liftIO $ expectedRange @=? foundRange
-
-canonicalizeLocation :: Location -> IO Location
-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range
-
-findDefinitionAndHoverTests :: TestTree
-findDefinitionAndHoverTests = let
-
-  tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
-
-    -- Dirty the cache to check that definitions work even in the presence of iface files
-    liftIO $ runInDir dir $ do
-      let fooPath = dir </> "Foo.hs"
-      fooSource <- liftIO $ readFileUtf8 fooPath
-      fooDoc <- createDoc fooPath "haskell" fooSource
-      _ <- getHover fooDoc $ Position 4 3
-      closeDoc fooDoc
-
-    doc <- openTestDataDoc (dir </> sourceFilePath)
-    void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
-    found <- get doc pos
-    check found targetRange
-
-
-
-  checkHover :: Maybe Hover -> Session [Expect] -> Session ()
-  checkHover hover expectations = traverse_ check =<< expectations where
-
-    check expected =
-      case hover of
-        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
-        Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg})
-                  ,_range    = rangeInHover } ->
-          case expected of
-            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg
-            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
-            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
-            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
-            _ -> pure () -- all other expectations not relevant to hover
-        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
-
-  extractLineColFromHoverMsg :: T.Text -> [T.Text]
-  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
-
-  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
-  checkHoverRange expectedRange rangeInHover msg =
-    let
-      lineCol = extractLineColFromHoverMsg msg
-      -- looks like hovers use 1-based numbering while definitions use 0-based
-      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.
-      adjust Position{_line = l, _character = c} =
-        Position{_line = l + 1, _character = c + 1}
-    in
-    case map (read . T.unpack) lineCol of
-      [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c
-      _     -> liftIO $ assertFailure $
-        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>
-        "\n but got: " <> show (msg, rangeInHover)
-
-  assertFoundIn :: T.Text -> T.Text -> Assertion
-  assertFoundIn part whole = assertBool
-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)
-    (part `T.isInfixOf` whole)
-
-  sourceFilePath = T.unpack sourceFileName
-  sourceFileName = "GotoHover.hs"
-
-  mkFindTests tests = testGroup "get"
-    [ testGroup "definition" $ mapMaybe fst tests
-    , testGroup "hover"      $ mapMaybe snd tests
-    , checkFileCompiles sourceFilePath $
-        expectDiagnostics
-          [ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ]
-    , testGroup "type-definition" typeDefinitionTests ]
-
-  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"
-                        , tst (getTypeDefinitions, checkDefs) opL16 (pure [ExpectNoDefinitions]) "Polymorphic variable"]
-
-  test runDef runHover look expect = testM runDef runHover look (return expect)
-
-  testM runDef runHover look expect title =
-    ( runDef   $ tst def   look expect title
-    , runHover $ tst hover look expect title ) where
-      def   = (getDefinitions, checkDefs)
-      hover = (getHover      , checkHover)
-
-  -- search locations            expectations on results
-  fffL4  = _start fffR     ;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]
-  fffL8  = Position 12  4  ;
-  fffL14 = Position 18  7  ;
-  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"]]
-  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"]]
-  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"]]
-  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]
-  lclL33 = Position 37 22
-  mclL36 = Position 40  1  ;  mcl    = [mkR  40  0   40 14]
-  mclL37 = Position 41  1
-  spaceL37 = Position 41  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
-  docL41 = Position 45  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]
-                           ;  constr = [ExpectHoverText ["Monad m"]]
-  eitL40 = Position 44 28  ;  kindE  = [ExpectHoverText [":: * -> * -> *\n"]]
-  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [":: *\n"]]
-  tvrL40 = Position 44 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]
-  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["7518"]]
-  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["'f'"]]
-  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]
-  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]
-  outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
-  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
-  holeL60 = Position 59 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]
-  cccL17 = Position 17 16  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]
-  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
-  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
-  in
-  mkFindTests
-  --      def    hover  look       expect
-  [ test  yes    yes    fffL4      fff           "field in record definition"
-  , test  yes    yes    fffL8      fff           "field in record construction     #71"
-  , test  yes    yes    fffL14     fff           "field name used as accessor"          -- 120 in Calculate.hs
-  , test  yes    yes    aaaL14     aaa           "top-level name"                       -- 120
-  , test  yes    yes    dcL7       tcDC          "data constructor record         #247"
-  , test  yes    yes    dcL12      tcDC          "data constructor plain"               -- 121
-  , test  yes    yes    tcL6       tcData        "type constructor                #248" -- 147
-  , test  broken yes    xtcL5      xtc           "type constructor external   #248,249"
-  , test  broken yes    xvL20      xvMsg         "value external package          #249" -- 120
-  , test  yes    yes    vvL16      vv            "plain parameter"                      -- 120
-  , test  yes    yes    aL18       apmp          "pattern match name"                   -- 120
-  , test  yes    yes    opL16      op            "top-level operator"                   -- 120, 123
-  , test  yes    yes    opL18      opp           "parameter operator"                   -- 120
-  , test  yes    yes    b'L19      bp            "name in backticks"                    -- 120
-  , test  yes    yes    clL23      cls           "class in instance declaration   #250"
-  , test  yes    yes    clL25      cls           "class in signature              #250" -- 147
-  , test  broken yes    eclL15     ecls          "external class in signature #249,250"
-  , test  yes    yes    dnbL29     dnb           "do-notation   bind"                   -- 137
-  , test  yes    yes    dnbL30     dnb           "do-notation lookup"
-  , test  yes    yes    lcbL33     lcb           "listcomp   bind"                      -- 137
-  , 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         #246"
-#if MIN_GHC_API_VERSION(8,10,0)
-  , test  yes    yes    spaceL37   space         "top-level fn on space #315"
-#else
-  , test  yes    broken spaceL37   space         "top-level fn on space #315"
-#endif
-  , test  no     yes    docL41     doc           "documentation                     #7"
-  , test  no     yes    eitL40     kindE         "kind of Either                  #273"
-  , test  no     yes    intL40     kindI         "kind of Int                     #273"
-  , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #273"
-  , test  no     broken intL41     litI          "literal Int  in hover info      #274"
-  , test  no     broken chrL36     litC          "literal Char in hover info      #274"
-  , test  no     broken txtL8      litT          "literal Text in hover info      #274"
-  , test  no     broken lstL43     litL          "literal List in hover info      #274"
-  , test  no     broken docL41     constr        "type constraint in hover info   #283"
-  , test  broken broken outL45     outSig        "top-level signature             #310"
-  , test  broken broken innL48     innSig        "inner     signature             #310"
-  , test  no     yes    holeL60    hleInfo       "hole without internal name      #847"
-  , test  no     skip   cccL17     docLink       "Haddock html links"
-  , testM yes    yes    imported   importedSig   "Imported symbol"
-  , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"
-  ]
-  where yes, broken :: (TestTree -> Maybe TestTree)
-        yes    = Just -- test should run and pass
-        broken = Just . (`xfail` "known broken")
-        no = const Nothing -- don't run this test at all
-        skip = const Nothing -- unreliable, don't run
-
-checkFileCompiles :: FilePath -> Session () -> TestTree
-checkFileCompiles fp diag =
-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
-    void (openTestDataDoc (dir </> fp))
-    diag
-
-pluginSimpleTests :: TestTree
-pluginSimpleTests =
-  ignoreTest8101 "GHC #18070" $
-  ignoreInWindowsForGHC88And810 $
-  testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do
-    _ <- openDoc (dir </> "KnownNat.hs") "haskell"
-    liftIO $ writeFile (dir</>"hie.yaml")
-      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"
-
-    expectDiagnostics
-      [ ( "KnownNat.hs",
-          [(DsError, (9, 15), "Variable not in scope: c")]
-          )
-      ]
-
-pluginParsedResultTests :: TestTree
-pluginParsedResultTests =
-  ignoreTest8101 "GHC #18070" $
-  ignoreInWindowsForGHC88And810 $
-  testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do
-    _ <- openDoc (dir</> "RecordDot.hs") "haskell"
-    expectNoMoreDiagnostics 2
-
-cppTests :: TestTree
-cppTests =
-  testGroup "cpp"
-    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do
-        let content =
-              T.unlines
-                [ "{-# LANGUAGE CPP #-}",
-                  "module Testing where",
-                  "#ifdef FOO",
-                  "foo = 42"
-                ]
-        -- The error locations differ depending on which C-preprocessor is used.
-        -- Some give the column number and others don't (hence -1). Assert either
-        -- of them.
-        (run $ expectError content (2, -1))
-          `catch` ( \e -> do
-                      let _ = e :: HUnitFailure
-                      run $ expectError content (2, 1)
-                  )
-    , testSessionWait "cpp-ghcide" $ do
-        _ <- createDoc "A.hs" "haskell" $ T.unlines
-          ["{-# LANGUAGE CPP #-}"
-          ,"main ="
-          ,"#ifdef __GHCIDE__"
-          ,"  worked"
-          ,"#else"
-          ,"  failed"
-          ,"#endif"
-          ]
-        expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
-    ]
-  where
-    expectError :: T.Text -> Cursor -> Session ()
-    expectError content cursor = do
-      _ <- createDoc "Testing.hs" "haskell" content
-      expectDiagnostics
-        [ ( "Testing.hs",
-            [(DsError, cursor, "error: unterminated")]
-          )
-        ]
-      expectNoMoreDiagnostics 0.5
-
-preprocessorTests :: TestTree
-preprocessorTests = testSessionWait "preprocessor" $ do
-  let content =
-        T.unlines
-          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
-          , "module Testing where"
-          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
-          ]
-  _ <- createDoc "Testing.hs" "haskell" content
-  expectDiagnostics
-    [ ( "Testing.hs",
-        [(DsError, (2, 8), "Variable not in scope: z")]
-      )
-    ]
-
-
-safeTests :: TestTree
-safeTests =
-  testGroup
-    "SafeHaskell"
-    [ -- Test for https://github.com/haskell/ghcide/issues/424
-      testSessionWait "load" $ do
-        let sourceA =
-              T.unlines
-                ["{-# LANGUAGE Trustworthy #-}"
-                ,"module A where"
-                ,"import System.IO.Unsafe"
-                ,"import System.IO ()"
-                ,"trustWorthyId :: a -> a"
-                ,"trustWorthyId i = unsafePerformIO $ do"
-                ,"  putStrLn \"I'm safe\""
-                ,"  return i"]
-            sourceB =
-              T.unlines
-                ["{-# LANGUAGE Safe #-}"
-                ,"module B where"
-                ,"import A"
-                ,"safeId :: a -> a"
-                ,"safeId = trustWorthyId"
-                ]
-
-        _ <- createDoc "A.hs" "haskell" sourceA
-        _ <- createDoc "B.hs" "haskell" sourceB
-        expectNoMoreDiagnostics 1 ]
-
-thTests :: TestTree
-thTests =
-  testGroup
-    "TemplateHaskell"
-    [ -- Test for https://github.com/haskell/ghcide/pull/212
-      testSessionWait "load" $ do
-        let sourceA =
-              T.unlines
-                [ "{-# LANGUAGE PackageImports #-}",
-                  "{-# LANGUAGE TemplateHaskell #-}",
-                  "module A where",
-                  "import \"template-haskell\" Language.Haskell.TH",
-                  "a :: Integer",
-                  "a = $(litE $ IntegerL 3)"
-                ]
-            sourceB =
-              T.unlines
-                [ "{-# LANGUAGE PackageImports #-}",
-                  "{-# LANGUAGE TemplateHaskell #-}",
-                  "module B where",
-                  "import A",
-                  "import \"template-haskell\" Language.Haskell.TH",
-                  "b :: Integer",
-                  "b = $(litE $ IntegerL $ a) + n"
-                ]
-        _ <- createDoc "A.hs" "haskell" sourceA
-        _ <- createDoc "B.hs" "haskell" sourceB
-        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
-    , testSessionWait "newtype-closure" $ do
-        let sourceA =
-              T.unlines
-                [ "{-# LANGUAGE DeriveDataTypeable #-}"
-                  ,"{-# LANGUAGE TemplateHaskell #-}"
-                  ,"module A (a) where"
-                  ,"import Data.Data"
-                  ,"import Language.Haskell.TH"
-                  ,"newtype A = A () deriving (Data)"
-                  ,"a :: ExpQ"
-                  ,"a = [| 0 |]"]
-        let sourceB =
-              T.unlines
-                [ "{-# LANGUAGE TemplateHaskell #-}"
-                ,"module B where"
-                ,"import A"
-                ,"b :: Int"
-                ,"b = $( a )" ]
-        _ <- createDoc "A.hs" "haskell" sourceA
-        _ <- createDoc "B.hs" "haskell" sourceB
-        return ()
-    , thReloadingTest
-    -- Regression test for https://github.com/haskell/ghcide/issues/614
-    , thLinkingTest
-    , testSessionWait "findsTHIdentifiers" $ do
-        let sourceA =
-              T.unlines
-                [ "{-# LANGUAGE TemplateHaskell #-}"
-                , "module A (a) where"
-                , "a = [| glorifiedID |]"
-                , "glorifiedID :: a -> a"
-                , "glorifiedID = id" ]
-        let sourceB =
-              T.unlines
-                [ "{-# OPTIONS_GHC -Wall #-}"
-                , "{-# LANGUAGE TemplateHaskell #-}"
-                , "module B where"
-                , "import A"
-                , "main = $a (putStrLn \"success!\")"]
-        _ <- createDoc "A.hs" "haskell" sourceA
-        _ <- createDoc "B.hs" "haskell" sourceB
-        expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]
-    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do
-
-    -- This test defines a TH value with the meaning "data A = A" in A.hs
-    -- Loads and export the template in B.hs
-    -- And checks wether the constructor A can be loaded in C.hs
-    -- This test does not fail when either A and B get manually loaded before C.hs
-    -- or when we remove the seemingly unnecessary TH pragma from C.hs
-
-    let cPath = dir </> "C.hs"
-    _ <- openDoc cPath "haskell"
-    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]
-    ]
-
--- | test that TH is reevaluated on typecheck
-thReloadingTest :: TestTree
-thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -> do
-
-    let aPath = dir </> "THA.hs"
-        bPath = dir </> "THB.hs"
-        cPath = dir </> "THC.hs"
-
-    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]
-    bSource <- liftIO $ readFileUtf8 bPath --  $th
-    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()
-
-    adoc <- createDoc aPath "haskell" aSource
-    bdoc <- createDoc bPath "haskell" bSource
-    cdoc <- createDoc cPath "haskell" cSource
-
-    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
-
-    -- Change th from () to Bool
-    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]
-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']
-    -- generate an artificial warning to avoid timing out if the TH change does not propagate
-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]
-
-    -- Check that the change propagates to C
-    expectDiagnostics
-        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])
-        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])
-        ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])
-        ]
-
-    closeDoc adoc
-    closeDoc bdoc
-    closeDoc cdoc
-
-thLinkingTest :: TestTree
-thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do
-
-    let aPath = dir </> "THA.hs"
-        bPath = dir </> "THB.hs"
-
-    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]
-    bSource <- liftIO $ readFileUtf8 bPath --  $th_a
-
-    adoc <- createDoc aPath "haskell" aSource
-    bdoc <- createDoc bPath "haskell" bSource
-
-    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
-
-    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]
-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']
-
-    -- modify b too
-    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]
-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']
-
-    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
-
-    closeDoc adoc
-    closeDoc bdoc
-
-
-completionTests :: TestTree
-completionTests
-  = testGroup "completion"
-    [ testGroup "non local" nonLocalCompletionTests
-    , testGroup "topLevel" topLevelCompletionTests
-    , testGroup "local" localCompletionTests
-    , testGroup "other" otherCompletionTests
-    ]
-
-completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree
-completionTest name src pos expected = testSessionWait name $ do
-    docId <- createDoc "A.hs" "haskell" (T.unlines src)
-    _ <- waitForDiagnostics
-    compls <- getCompletions docId pos
-    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]
-    liftIO $ do
-        let emptyToMaybe x = if T.null x then Nothing else Just x
-        compls' @?= [ (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)
-            when expectedDocs $
-                assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)
-
-topLevelCompletionTests :: [TestTree]
-topLevelCompletionTests = [
-    completionTest
-        "variable"
-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
-        (Position 0 8)
-        [("xxx", CiFunction, "xxx", True, True, Nothing),
-         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
-        ],
-    completionTest
-        "constructor"
-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
-        (Position 0 8)
-        [("xxx", CiFunction, "xxx", True, True, Nothing),
-         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
-        ],
-    completionTest
-        "class method"
-        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]
-        (Position 0 8)
-        [("xxx", CiFunction, "xxx", True, True, Nothing)],
-    completionTest
-        "type"
-        ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
-        (Position 0 9)
-        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],
-    completionTest
-        "class"
-        ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]
-        (Position 0 9)
-        [("Xxx", CiClass, "Xxx", False, True, Nothing)],
-    completionTest
-        "records"
-        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]
-        (Position 1 19)
-        [("_personName", CiFunction, "_personName", False, True, Nothing),
-         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],
-    completionTest
-        "recordsConstructor"
-        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]
-        (Position 1 19)
-        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),
-         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]
-    ]
-
-localCompletionTests :: [TestTree]
-localCompletionTests = [
-    completionTest
-        "argument"
-        ["bar (Just abcdef) abcdefg = abcd"]
-        (Position 0 32)
-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),
-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)
-        ],
-    completionTest
-        "let"
-        ["bar = let (Just abcdef) = undefined"
-        ,"          abcdefg = let abcd = undefined in undefined"
-        ,"        in abcd"
-        ]
-        (Position 2 15)
-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),
-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)
-        ],
-    completionTest
-        "where"
-        ["bar = abcd"
-        ,"  where (Just abcdef) = undefined"
-        ,"        abcdefg = let abcd = undefined in undefined"
-        ]
-        (Position 0 10)
-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),
-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)
-        ],
-    completionTest
-        "do/1"
-        ["bar = do"
-        ,"  Just abcdef <- undefined"
-        ,"  abcd"
-        ,"  abcdefg <- undefined"
-        ,"  pure ()"
-        ]
-        (Position 2 6)
-        [("abcdef", CiFunction, "abcdef", True, False, Nothing)
-        ],
-    completionTest
-        "do/2"
-        ["bar abcde = do"
-        ,"    Just [(abcdef,_)] <- undefined"
-        ,"    abcdefg <- undefined"
-        ,"    let abcdefgh = undefined"
-        ,"        (Just [abcdefghi]) = undefined"
-        ,"    abcd"
-        ,"  where"
-        ,"    abcdefghij = undefined"
-        ]
-        (Position 5 8)
-        [("abcde", CiFunction, "abcde", True, False, Nothing)
-        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)
-        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)
-        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)
-        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)
-        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)
-        ]
-    ]
-
-nonLocalCompletionTests :: [TestTree]
-nonLocalCompletionTests =
-  [ completionTest
-      "variable"
-      ["module A where", "f = hea"]
-      (Position 1 7)
-      [("head", CiFunction, "head ${1:[a]}", True, True, Nothing)],
-    completionTest
-      "constructor"
-      ["module A where", "f = Tru"]
-      (Position 1 7)
-      [ ("True", CiConstructor, "True ", True, True, Nothing),
-        ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)
-      ],
-    completionTest
-      "type"
-      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]
-      (Position 2 7)
-      [ ("Bounded", CiClass, "Bounded ${1:*}", True, True, Nothing),
-        ("Bool", CiStruct, "Bool ", True, True, Nothing)
-      ],
-    completionTest
-      "qualified"
-      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]
-      (Position 2 15)
-      [ ("head", CiFunction, "head ${1:[a]}", True, True, Nothing)
-      ],
-    completionTest
-      "duplicate import"
-      ["module A where", "import Data.List", "import Data.List", "f = perm"]
-      (Position 3 8)
-      [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing)
-      ],
-    completionTest
-       "dont show hidden items"
-       [ "{-# LANGUAGE NoImplicitPrelude #-}",
-         "module A where",
-         "import Control.Monad hiding (join)",
-         "f = joi"
-       ]
-       (Position 3 6)
-       [],
-    expectFailBecause "Auto import completion snippets were disabled in v0.6.0.2" $
-      testGroup "auto import snippets"
-      [ completionTest
-        "show imports not in list - simple"
-        ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import Control.Monad (msum)", "f = joi"]
-        (Position 3 6)
-        [("join", CiFunction, "join ${1:m (m a)}", False, False,
-            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 26}, _end = Position {_line = 2, _character = 26}}, _newText = "join, "}]))]
-      , completionTest
-        "show imports not in list - multi-line"
-        ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import Control.Monad (\n    msum)", "f = joi"]
-        (Position 4 6)
-        [("join", CiFunction, "join ${1:m (m a)}", False, False,
-            Just (List [TextEdit {_range = Range {_start = Position {_line = 3, _character = 8}, _end = Position {_line = 3, _character = 8}}, _newText = "join, "}]))]
-      , completionTest
-        "show imports not in list - names with _"
-        ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import qualified Control.Monad as M (msum)", "f = M.mapM_"]
-        (Position 3 11)
-        [("mapM_", CiFunction, "mapM_ ${1:a -> m b} ${2:t a}", False, False,
-            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 41}, _end = Position {_line = 2, _character = 41}}, _newText = "mapM_, "}]))]
-      , completionTest
-        "show imports not in list - initial empty list"
-        ["{-# LANGUAGE NoImplicitPrelude #-}",
-        "module A where", "import qualified Control.Monad as M ()", "f = M.joi"]
-        (Position 3 10)
-        [("join", CiFunction, "join ${1:m (m a)}", False, False,
-            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 37}, _end = Position {_line = 2, _character = 37}}, _newText = "join, "}]))]
-      , completionTest
-        "record snippet on import"
-        ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"]
-        (Position 2 10)
-        [("FormatParse", CiStruct, "FormatParse ", False, False,
-        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),
-        ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False,
-        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),
-        ("FormatParse", CiSnippet, "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False,
-        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}]))
-        ]
-      ],
-      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls
-     completionTest
-      "do not show pragma completions"
-      [ "{-# LANGUAGE  ",
-        "{module A where}",
-        "main = return ()"
-      ]
-      (Position 0 13)
-      []
-  ]
-
-otherCompletionTests :: [TestTree]
-otherCompletionTests = [
-    completionTest
-      "keyword"
-      ["module A where", "f = newty"]
-      (Position 1 9)
-      [("newtype", CiKeyword, "", False, False, Nothing)],
-    completionTest
-      "type context"
-      [ "{-# OPTIONS_GHC -Wunused-binds #-}",
-        "module A () where",
-        "f = f",
-        "g :: Intege"
-      ]
-      -- At this point the module parses but does not typecheck.
-      -- This should be sufficient to detect that we are in a
-      -- type context and only show the completion to the type.
-      (Position 3 11)
-      [("Integer", CiStruct, "Integer ", True, True, Nothing)]
-  ]
-
-highlightTests :: TestTree
-highlightTests = testGroup "highlight"
-  [ testSessionWait "value" $ do
-    doc <- createDoc "A.hs" "haskell" source
-    _ <- waitForDiagnostics
-    highlights <- getHighlights doc (Position 3 2)
-    liftIO $ highlights @?=
-            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)
-            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)
-            , DocumentHighlight (R 4 6 4 9) (Just HkRead)
-            , DocumentHighlight (R 5 22 5 25) (Just HkRead)
-            ]
-  , testSessionWait "type" $ do
-    doc <- createDoc "A.hs" "haskell" source
-    _ <- waitForDiagnostics
-    highlights <- getHighlights doc (Position 2 8)
-    liftIO $ highlights @?=
-            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)
-            , DocumentHighlight (R 3 11 3 14) (Just HkRead)
-            ]
-  , testSessionWait "local" $ do
-    doc <- createDoc "A.hs" "haskell" source
-    _ <- waitForDiagnostics
-    highlights <- getHighlights doc (Position 6 5)
-    liftIO $ highlights @?=
-            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)
-            , DocumentHighlight (R 6 10 6 13) (Just HkRead)
-            , DocumentHighlight (R 7 12 7 15) (Just HkRead)
-            ]
-  , testSessionWait "record" $ do
-    doc <- createDoc "A.hs" "haskell" recsource
-    _ <- waitForDiagnostics
-    highlights <- getHighlights doc (Position 4 15)
-    liftIO $ highlights @?=
-      -- Span is just the .. on 8.10, but Rec{..} before
-#if MIN_GHC_API_VERSION(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 @?=
-            [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)
-      -- Span is just the .. on 8.10, but Rec{..} before
-#if MIN_GHC_API_VERSION(8,10,0)
-            , DocumentHighlight (R 4 8 4 10) (Just HkRead)
-#else
-            , DocumentHighlight (R 4 4 4 11) (Just HkRead)
-#endif
-            ]
-  ]
-  where
-    source = T.unlines
-      ["{-# OPTIONS_GHC -Wunused-binds #-}"
-      ,"module Highlight () where"
-      ,"foo :: Int"
-      ,"foo = 3 :: Int"
-      ,"bar = foo"
-      ,"  where baz = let x = foo in x"
-      ,"baz arg = arg + x"
-      ,"  where x = arg"
-      ]
-    recsource = T.unlines
-      ["{-# LANGUAGE RecordWildCards #-}"
-      ,"{-# OPTIONS_GHC -Wunused-binds #-}"
-      ,"module Highlight () where"
-      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"
-      ,"foo Rec{..} = field2 + field1"
-      ]
-
-outlineTests :: TestTree
-outlineTests = testGroup
-  "outline"
-  [ testSessionWait "type class" $ do
-    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [ moduleSymbol
-          "A"
-          (R 0 7 0 8)
-          [ classSymbol "A a"
-                        (R 1 0 1 30)
-                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
-          ]
-      ]
-  , testSessionWait "type class instance " $ do
-    let source = T.unlines ["class A a where", "instance A () where"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [ classSymbol "A a" (R 0 0 0 15) []
-      , docSymbol "A ()" SkInterface (R 1 0 1 19)
-      ]
-  , testSessionWait "type family" $ do
-    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
-  , testSessionWait "type family instance " $ do
-    let source = T.unlines
-          [ "{-# language TypeFamilies #-}"
-          , "type family A a"
-          , "type instance A () = ()"
-          ]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [ docSymbolD "A a"   "type family" SkClass     (R 1 0 1 15)
-      , docSymbol "A ()" SkInterface (R 2 0 2 23)
-      ]
-  , testSessionWait "data family" $ do
-    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
-  , testSessionWait "data family instance " $ do
-    let source = T.unlines
-          [ "{-# language TypeFamilies #-}"
-          , "data family A a"
-          , "data instance A () = A ()"
-          ]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [ docSymbolD "A a"   "data family" SkClass     (R 1 0 1 11)
-      , docSymbol "A ()" SkInterface (R 2 0 2 25)
-      ]
-  , testSessionWait "constant" $ do
-    let source = T.unlines ["a = ()"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbol "a" SkFunction (R 0 0 0 6)]
-  , testSessionWait "pattern" $ do
-    let source = T.unlines ["Just foo = Just 21"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
-  , testSessionWait "pattern with type signature" $ do
-    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
-  , testSessionWait "function" $ do
-    let source = T.unlines ["a _x = ()"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)]
-  , testSessionWait "type synonym" $ do
-    let source = T.unlines ["type A = Bool"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
-  , testSessionWait "datatype" $ do
-    let source = T.unlines ["data A = C"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [ docSymbolWithChildren "A"
-                              SkStruct
-                              (R 0 0 0 10)
-                              [docSymbol "C" SkConstructor (R 0 9 0 10)]
-      ]
-  , testSessionWait "record fields" $ do
-    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @=? Left
-      [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
-          [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
-            [ docSymbol "x" SkField (R 1 2 1 3)
-            , docSymbol "y" SkField (R 2 4 2 5)
-            ]
-          ]
-      ]
-  , testSessionWait "import" $ do
-    let source = T.unlines ["import Data.Maybe ()"]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbolWithChildren "imports"
-                             SkModule
-                             (R 0 0 0 20)
-                             [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20)
-                             ]
-      ]
-  , testSessionWait "multiple import" $ do
-    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left
-      [docSymbolWithChildren "imports"
-                             SkModule
-                             (R 1 0 3 27)
-                             [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20)
-                             , docSymbol "import Control.Exception" SkModule (R 3 0 3 27)
-                             ]
-      ]
-  , testSessionWait "foreign import" $ do
-    let source = T.unlines
-          [ "{-# language ForeignFunctionInterface #-}"
-          , "foreign import ccall \"a\" a :: Int"
-          ]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
-  , testSessionWait "foreign export" $ do
-    let source = T.unlines
-          [ "{-# language ForeignFunctionInterface #-}"
-          , "foreign export ccall odd :: Int -> Bool"
-          ]
-    docId   <- createDoc "A.hs" "haskell" source
-    symbols <- getDocumentSymbols docId
-    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
-  ]
- where
-  docSymbol name kind loc =
-    DocumentSymbol name Nothing kind Nothing loc loc Nothing
-  docSymbol' name kind loc selectionLoc =
-    DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing
-  docSymbolD name detail kind loc =
-    DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
-  docSymbolWithChildren name kind loc cc =
-    DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
-  docSymbolWithChildren' name kind loc selectionLoc cc =
-    DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
-  moduleSymbol name loc cc = DocumentSymbol name
-                                            Nothing
-                                            SkFile
-                                            Nothing
-                                            (R 0 0 maxBound 0)
-                                            loc
-                                            (Just $ List cc)
-  classSymbol name loc cc = DocumentSymbol name
-                                           (Just "class")
-                                           SkClass
-                                           Nothing
-                                           loc
-                                           loc
-                                           (Just $ List cc)
-
-pattern R :: Int -> Int -> Int -> Int -> Range
-pattern R x y x' y' = Range (Position x y) (Position x' y')
-
-xfail :: TestTree -> String -> TestTree
-xfail = flip expectFailBecause
-
-ignoreTest8101 :: String -> TestTree -> TestTree
-ignoreTest8101
-  | GHC_API_VERSION == ("8.10.1" :: String) = ignoreTestBecause
-  | otherwise = const id
-
-ignoreInWindowsBecause :: String -> TestTree -> TestTree
-ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x)
-
-ignoreInWindowsForGHC88And810 :: TestTree -> TestTree
-#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0)
-ignoreInWindowsForGHC88And810 =
-    ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10"
-#else
-ignoreInWindowsForGHC88And810 = id
-#endif
-
-ignoreInWindowsForGHC88 :: TestTree -> TestTree
-#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1)
-ignoreInWindowsForGHC88 =
-    ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8"
-#else
-ignoreInWindowsForGHC88 = id
-#endif
-
-data Expect
-  = ExpectRange Range -- Both gotoDef and hover should report this range
-  | ExpectLocation Location
---  | ExpectDefRange Range -- Only gotoDef should report this range
-  | ExpectHoverRange Range -- Only hover should report this range
-  | ExpectHoverText [T.Text] -- the hover message must contain these snippets
-  | ExpectExternFail -- definition lookup in other file expected to fail
-  | ExpectNoDefinitions
-  | ExpectNoHover
---  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
-  deriving Eq
-
-mkR :: Int -> Int -> Int -> Int -> Expect
-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
-
-mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
-
-haddockTests :: TestTree
-haddockTests
-  = testGroup "haddock"
-      [ testCase "Num" $ checkHaddock
-          (unlines
-             [ "However, '(+)' and '(*)' are"
-             , "customarily expected to define a ring and have the following properties:"
-             , ""
-             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
-             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
-             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
-             ]
-          )
-          (unlines
-             [ ""
-             , ""
-             , "However,  `(+)`  and  `(*)`  are"
-             , "customarily expected to define a ring and have the following properties: "
-             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"
-             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"
-             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"
-             ]
-          )
-      , testCase "unsafePerformIO" $ checkHaddock
-          (unlines
-             [ "may require"
-             , "different precautions:"
-             , ""
-             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
-             , "        that calls 'unsafePerformIO'.  If the call is inlined,"
-             , "        the I\\/O may be performed more than once."
-             , ""
-             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
-             , "        elimination being performed on the module."
-             , ""
-             ]
-          )
-          (unlines
-             [ ""
-             , ""
-             , "may require"
-             , "different precautions: "
-             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "
-             , "  that calls  `unsafePerformIO` .  If the call is inlined,"
-             , "  the I/O may be performed more than once."
-             , ""
-             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"
-             , "  elimination being performed on the module."
-             , ""
-             ]
-          )
-      ]
-  where
-    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
-
-cradleTests :: TestTree
-cradleTests = testGroup "cradle"
-    [testGroup "dependencies" [sessionDepsArePickedUp]
-    ,testGroup "ignore-fatal" [ignoreFatalWarning]
-    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]
-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]
-    ,testGroup "sub-directory"   [simpleSubDirectoryTest]
-    ]
-
-loadCradleOnlyonce :: TestTree
-loadCradleOnlyonce = testGroup "load cradle only once"
-    [ testSession' "implicit" implicit
-    , testSession' "direct"   direct
-    ]
-    where
-        direct dir = do
-            liftIO $ writeFileUTF8 (dir </> "hie.yaml")
-                "cradle: {direct: {arguments: []}}"
-            test dir
-        implicit dir = test dir
-        test _dir = do
-            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
-            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
-            liftIO $ length msgs @?= 1
-            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
-            liftIO $ length msgs @?= 0
-            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
-            liftIO $ length msgs @?= 0
-
-retryFailedCradle :: TestTree
-retryFailedCradle = testSession' "retry failed" $ \dir -> do
-  -- The false cradle always fails
-  let hieContents = "cradle: {bios: {shell: \"false\"}}"
-      hiePath = dir </> "hie.yaml"
-  liftIO $ writeFile hiePath hieContents
-  hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents
-  let aPath = dir </> "A.hs"
-  doc <- createDoc aPath "haskell" "main = return ()"
-  Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
-  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
-
-  -- Fix the cradle and typecheck again
-  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"
-  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle
-  changeDoc
-    hieDoc
-    [ TextDocumentContentChangeEvent
-        { _range = Nothing,
-          _rangeLength = Nothing,
-          _text = validCradle
-        }
-    ]
-
-  -- Force a session restart by making an edit, just to dirty the typecheck node
-  changeDoc
-    doc
-    [ TextDocumentContentChangeEvent
-        { _range = Just Range {_start = Position 0 0, _end = Position 0 0},
-          _rangeLength = Nothing,
-          _text = "\n"
-        }
-    ]
-
-  Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
-  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess
-
-
-dependentFileTest :: TestTree
-dependentFileTest = testGroup "addDependentFile"
-    [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test]
-    ]
-    where
-      test dir = do
-        -- If the file contains B then no type error
-        -- otherwise type error
-        liftIO $ writeFile (dir </> "dep-file.txt") "A"
-        let fooContent = T.unlines
-              [ "{-# LANGUAGE TemplateHaskell #-}"
-              , "module Foo where"
-              , "import Language.Haskell.TH.Syntax"
-              , "foo :: Int"
-              , "foo = 1 + $(do"
-              , "               qAddDependentFile \"dep-file.txt\""
-              , "               f <- qRunIO (readFile \"dep-file.txt\")"
-              , "               if f == \"B\" then [| 1 |] else lift f)"
-              ]
-        let bazContent = T.unlines ["module Baz where", "import Foo ()"]
-        _ <-createDoc "Foo.hs" "haskell" fooContent
-        doc <- createDoc "Baz.hs" "haskell" bazContent
-        expectDiagnostics
-          [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
-        -- Now modify the dependent file
-        liftIO $ writeFile (dir </> "dep-file.txt") "B"
-        let change = TextDocumentContentChangeEvent
-              { _range = Just (Range (Position 2 0) (Position 2 6))
-              , _rangeLength = Nothing
-              , _text = "f = ()"
-              }
-        -- Modifying Baz will now trigger Foo to be rebuilt as well
-        changeDoc doc [change]
-        expectDiagnostics [("Foo.hs", [])]
-
-
-cradleLoadedMessage :: Session FromServerMessage
-cradleLoadedMessage = satisfy $ \case
-        NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
-        _ -> False
-
-cradleLoadedMethod :: T.Text
-cradleLoadedMethod = "ghcide/cradle/loaded"
-
-ignoreFatalWarning :: TestTree
-ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do
-    let srcPath = dir </> "IgnoreFatal.hs"
-    src <- liftIO $ readFileUtf8 srcPath
-    _ <- createDoc srcPath "haskell" src
-    expectNoMoreDiagnostics 5
-
-simpleSubDirectoryTest :: TestTree
-simpleSubDirectoryTest =
-  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do
-    let mainPath = dir </> "a/src/Main.hs"
-    mainSource <- liftIO $ readFileUtf8 mainPath
-    _mdoc <- createDoc mainPath "haskell" mainSource
-    expectDiagnosticsWithTags
-      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded
-      ]
-    expectNoMoreDiagnostics 0.5
-
-simpleMultiTest :: TestTree
-simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do
-    let aPath = dir </> "a/A.hs"
-        bPath = dir </> "b/B.hs"
-    aSource <- liftIO $ readFileUtf8 aPath
-    adoc <- createDoc aPath "haskell" aSource
-    Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc
-    liftIO $ assertBool "A should typecheck" ideResultSuccess
-    bSource <- liftIO $ readFileUtf8 bPath
-    bdoc <- createDoc bPath "haskell" bSource
-    Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc
-    liftIO $ assertBool "B should typecheck" ideResultSuccess
-    locs <- getDefinitions bdoc (Position 2 7)
-    let fooL = mkL (adoc ^. L.uri) 2 0 2 3
-    checkDefs locs (pure [fooL])
-    expectNoMoreDiagnostics 0.5
-
--- Like simpleMultiTest but open the files in the other order
-simpleMultiTest2 :: TestTree
-simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do
-    let aPath = dir </> "a/A.hs"
-        bPath = dir </> "b/B.hs"
-    bSource <- liftIO $ readFileUtf8 bPath
-    bdoc <- createDoc bPath "haskell" bSource
-    expectNoMoreDiagnostics 10
-    aSource <- liftIO $ readFileUtf8 aPath
-    (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
-    -- Need to have some delay here or the test fails
-    expectNoMoreDiagnostics 10
-    locs <- getDefinitions bdoc (Position 2 7)
-    let fooL = mkL adoc 2 0 2 3
-    checkDefs locs (pure [fooL])
-    expectNoMoreDiagnostics 0.5
-
-ifaceTests :: TestTree
-ifaceTests = testGroup "Interface loading tests"
-    [ -- https://github.com/haskell/ghcide/pull/645/
-      ifaceErrorTest
-    , ifaceErrorTest2
-    , ifaceErrorTest3
-    , ifaceTHTest
-    ]
-
-bootTests :: TestTree
-bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do
-  let cPath = dir </> "C.hs"
-  cSource <- liftIO $ readFileUtf8 cPath
-
-  -- Dirty the cache
-  liftIO $ runInDir dir $ do
-    cDoc <- createDoc cPath "haskell" cSource
-    _ <- getHover cDoc $ Position 4 3
-    closeDoc cDoc
-
-  cdoc <- createDoc cPath "haskell" cSource
-  locs <- getDefinitions cdoc (Position 7 4)
-  let floc = mkR 7 0 7 1
-  checkDefs locs (pure [floc])
-
--- | test that TH reevaluates across interfaces
-ifaceTHTest :: TestTree
-ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do
-    let aPath = dir </> "THA.hs"
-        bPath = dir </> "THB.hs"
-        cPath = dir </> "THC.hs"
-
-    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()
-    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()
-    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()
-
-    cdoc <- createDoc cPath "haskell" cSource
-
-    -- Change [TH]a from () to Bool
-    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
-
-    -- Check that the change propogates to C
-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]
-    expectDiagnostics
-      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])
-      ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]
-    closeDoc cdoc
-
-ifaceErrorTest :: TestTree
-ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do
-    let bPath = dir </> "B.hs"
-        pPath = dir </> "P.hs"
-
-    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int
-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int
-
-    bdoc <- createDoc bPath "haskell" bSource
-    expectDiagnostics
-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded
-
-    -- Change y from Int to B
-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]
-    -- save so that we can that the error propogates to A
-    sendNotification TextDocumentDidSave (DidSaveTextDocumentParams bdoc)
-
-    -- Check that the error propogates to A
-    expectDiagnostics
-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]
-
-
-    -- Check that we wrote the interfaces for B when we saved
-    lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath
-    res <- skipManyTill anyMessage $ responseForId lid
-    liftIO $ case res of
-      ResponseMessage{_result=Right hidir} -> do
-        hi_exists <- doesFileExist $ hidir </> "B.hi"
-        assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists
-      _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res
-
-    pdoc <- createDoc pPath "haskell" pSource
-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]
-    -- Now in P we have
-    -- bar = x :: Int
-    -- foo = y :: Bool
-    -- HOWEVER, in A...
-    -- x = y  :: Int
-    -- This is clearly inconsistent, and the expected outcome a bit surprising:
-    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics
-    --   - P is being typechecked with the last successful artifacts for A.
-    expectDiagnostics
-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])
-      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])
-      ]
-    expectNoMoreDiagnostics 2
-
-ifaceErrorTest2 :: TestTree
-ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do
-    let bPath = dir </> "B.hs"
-        pPath = dir </> "P.hs"
-
-    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int
-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int
-
-    bdoc <- createDoc bPath "haskell" bSource
-    pdoc <- createDoc pPath "haskell" pSource
-    expectDiagnostics
-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded
-
-    -- Change y from Int to B
-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]
-
-    -- Add a new definition to P
-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]
-    -- Now in P we have
-    -- bar = x :: Int
-    -- foo = y :: Bool
-    -- HOWEVER, in A...
-    -- x = y  :: Int
-    expectDiagnostics
-    -- As in the other test, P is being typechecked with the last successful artifacts for A
-    -- (ot thanks to -fdeferred-type-errors)
-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])
-      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])
-      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])
-      ]
-
-    expectNoMoreDiagnostics 2
-
-ifaceErrorTest3 :: TestTree
-ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do
-    let bPath = dir </> "B.hs"
-        pPath = dir </> "P.hs"
-
-    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int
-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int
-
-    bdoc <- createDoc bPath "haskell" bSource
-
-    -- Change y from Int to B
-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]
-
-    -- P should not typecheck, as there are no last valid artifacts for A
-    _pdoc <- createDoc pPath "haskell" pSource
-
-    -- In this example the interface file for A should not exist (modulo the cache folder)
-    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors
-    expectDiagnostics
-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])
-      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])
-      ]
-    expectNoMoreDiagnostics 2
-
-sessionDepsArePickedUp :: TestTree
-sessionDepsArePickedUp = testSession'
-  "session-deps-are-picked-up"
-  $ \dir -> do
-    liftIO $
-      writeFileUTF8
-        (dir </> "hie.yaml")
-        "cradle: {direct: {arguments: []}}"
-    -- Open without OverloadedStrings and expect an error.
-    doc <- createDoc "Foo.hs" "haskell" fooContent
-    expectDiagnostics
-      [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
-    -- Update hie.yaml to enable OverloadedStrings.
-    liftIO $
-      writeFileUTF8
-        (dir </> "hie.yaml")
-        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
-    -- Send change event.
-    let change =
-          TextDocumentContentChangeEvent
-            { _range = Just (Range (Position 4 0) (Position 4 0)),
-              _rangeLength = Nothing,
-              _text = "\n"
-            }
-    changeDoc doc [change]
-    -- Now no errors.
-    expectDiagnostics [("Foo.hs", [])]
-  where
-    fooContent =
-      T.unlines
-        [ "module Foo where",
-          "import Data.Text",
-          "foo :: Text",
-          "foo = \"hello\""
-        ]
-
--- A test to ensure that the command line ghcide workflow stays working
-nonLspCommandLine :: TestTree
-nonLspCommandLine = testGroup "ghcide command line"
-  [ testCase "works" $ withTempDir $ \dir -> do
-        ghcide <- locateGhcideExecutable
-        copyTestDataFiles dir "multi"
-        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}
-
-        setEnv "HOME" "/homeless-shelter" False
-
-        (ec, _, _) <- readCreateProcessWithExitCode cmd ""
-
-        ec @=? ExitSuccess
-  ]
-
-benchmarkTests :: TestTree
-benchmarkTests =
-    let ?config = Bench.defConfig
-            { Bench.verbosity = Bench.Quiet
-            , Bench.repetitions = Just 3
-            , Bench.buildTool = Bench.Cabal
-            } in
-    withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"
-    [ testCase (Bench.name e) $ do
-        Bench.SetupResult{Bench.benchDir} <- getResource
-        res <- Bench.runBench (runInDir benchDir) e
-        assertBool "did not successfully complete 5 repetitions" $ Bench.success res
-        | e <- Bench.experiments
-        , Bench.name e /= "edit" -- the edit experiment does not ever fail
-    ]
-
--- | checks if we use InitializeParams.rootUri for loading session
-rootUriTests :: TestTree
-rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
-  let bPath = dir </> "dirB/Foo.hs"
-  liftIO $ copyTestDataFiles dir "rootUri"
-  bSource <- liftIO $ readFileUtf8 bPath
-  _ <- createDoc "Foo.hs" "haskell" bSource
-  expectNoMoreDiagnostics 0.5
-  where
-    -- similar to run' except we can configure where to start ghcide and session
-    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()
-    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)
-
--- | Test if ghcide asynchronously handles Commands and user Requests
-asyncTests :: TestTree
-asyncTests = testGroup "async"
-    [
-      testSession "command" $ do
-            -- Execute a command that will block forever
-            let req = ExecuteCommandParams blockCommandId Nothing Nothing
-            void $ sendRequest WorkspaceExecuteCommand req
-            -- Load a file and check for code actions. Will only work if the command is run asynchronously
-            doc <- createDoc "A.hs" "haskell" $ T.unlines
-              [ "{-# OPTIONS -Wmissing-signatures #-}"
-              , "foo = id"
-              ]
-            void waitForDiagnostics
-            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))
-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
-    , testSession "request" $ do
-            -- Execute a custom request that will block for 1000 seconds
-            void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000
-            -- Load a file and check for code actions. Will only work if the request is run asynchronously
-            doc <- createDoc "A.hs" "haskell" $ T.unlines
-              [ "{-# OPTIONS -Wmissing-signatures #-}"
-              , "foo = id"
-              ]
-            void waitForDiagnostics
-            actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))
-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
-    ]
-
-
-clientSettingsTest :: TestTree
-clientSettingsTest = testGroup "client settings handling"
-    [
-        testSession "ghcide does not support update config" $ do
-            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))
-            logNot <- skipManyTill anyMessage loggingNotification
-            isMessagePresent "Updating Not supported" [getLogMessage logNot]
-    ,   testSession "ghcide restarts shake session on config changes" $ do
-            void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest
-            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))
-            nots <- skipManyTill anyMessage $ count 3 loggingNotification
-            isMessagePresent "Restarting build session" (map getLogMessage nots)
-
-    ]
-  where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg
-        getLogMessage _ = ""
-
-        isMessagePresent expectedMsg actualMsgs = liftIO $
-            assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs)
-                       (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs)
-----------------------------------------------------------------------
--- Utils
-----------------------------------------------------------------------
-
-testSession :: String -> Session () -> TestTree
-testSession name = testCase name . run
-
-testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
-
-testSession' :: String -> (FilePath -> Session ()) -> TestTree
-testSession' name = testCase name . run'
-
-testSessionWait :: String -> Session () -> TestTree
-testSessionWait name = testSession name .
-      -- Check that any diagnostics produced were already consumed by the test case.
-      --
-      -- If in future we add test cases where we don't care about checking the diagnostics,
-      -- this could move elsewhere.
-      --
-      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
-      ( >> expectNoMoreDiagnostics 0.5)
-
-pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
-pickActionWithTitle title actions = do
-  assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)
-  return $ head matches
-  where
-    titles =
-        [ actionTitle
-        | CACodeAction CodeAction { _title = actionTitle } <- actions
-        ]
-    matches =
-        [ action
-        | CACodeAction action@CodeAction { _title = actionTitle } <- actions
-        , title == actionTitle
-        ]
-
-mkRange :: Int -> Int -> Int -> Int -> Range
-mkRange a b c d = Range (Position a b) (Position c d)
-
-run :: Session a -> IO a
-run s = run' (const s)
-
-runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
-runWithExtraFiles prefix s = withTempDir $ \dir -> do
-  copyTestDataFiles dir prefix
-  runInDir dir (s dir)
-
-copyTestDataFiles :: FilePath -> FilePath -> IO ()
-copyTestDataFiles dir prefix = do
-  -- Copy all the test data files to the temporary workspace
-  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
-  for_ testDataFiles $ \f -> do
-    createDirectoryIfMissing True $ dir </> takeDirectory f
-    copyFile ("test/data" </> prefix </> f) (dir </> f)
-
-run' :: (FilePath -> Session a) -> IO a
-run' s = withTempDir $ \dir -> runInDir dir (s dir)
-
-runInDir :: FilePath -> Session a -> IO a
-runInDir dir = runInDir' dir "." "." []
-
-withLongTimeout :: IO a -> IO a
-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")
-
--- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.
-runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a
-runInDir' dir startExeIn startSessionIn extraOptions s = do
-  ghcideExe <- locateGhcideExecutable
-  let startDir = dir </> startExeIn
-  let projDir = dir </> startSessionIn
-
-  createDirectoryIfMissing True startDir
-  createDirectoryIfMissing True projDir
-  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
-  -- since the package import test creates "Data/List.hs", which otherwise has no physical home
-  createDirectoryIfMissing True $ projDir ++ "/Data"
-
-  let cmd = unwords $
-       [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir] ++ extraOptions
-  -- HIE calls getXgdDirectory which assumes that HOME is set.
-  -- Only sets HOME if it wasn't already set.
-  setEnv "HOME" "/homeless-shelter" False
-  let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
-  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"
-  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"
-  let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}
-            -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging
-            --   { logStdErr = True }
-            --   uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages
-            --   { logMessages = True }
-  runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s
-  where
-    checkEnv :: String -> IO (Maybe Bool)
-    checkEnv s = fmap convertVal <$> getEnv s
-    convertVal "0" = False
-    convertVal _ = True
-
-openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
-openTestDataDoc path = do
-  source <- liftIO $ readFileUtf8 $ "test/data" </> path
-  createDoc path "haskell" source
-
-findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
-findCodeActions = findCodeActions' (==) "is not a superset of"
-
-findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
-findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of"
-
-findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
-findCodeActions' op errMsg doc range expectedTitles = do
-  actions <- getCodeActions doc range
-  let matches = sequence
-        [ listToMaybe
-          [ action
-          | CACodeAction action@CodeAction { _title = actionTitle } <- actions
-          , expectedTitle `op` actionTitle]
-        | expectedTitle <- expectedTitles]
-  let msg = show
-            [ actionTitle
-            | CACodeAction CodeAction { _title = actionTitle } <- actions
-            ]
-            ++ " " <> errMsg <> " "
-            ++ show expectedTitles
-  liftIO $ case matches of
-    Nothing -> assertFailure msg
-    Just _ -> pure ()
-  return (fromJust matches)
-
-findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
-findCodeAction doc range t = head <$> findCodeActions doc range [t]
-
-unitTests :: TestTree
-unitTests = do
-  testGroup "Unit"
-     [ testCase "empty file path does NOT work with the empty String literal" $
-         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
-     , testCase "empty file path works using toNormalizedFilePath'" $
-         uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
-     , testCase "empty path URI" $ do
-         Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
-         uriScheme @?= "file:"
-         uriPath @?= ""
-     , testCase "from empty path URI" $ do
-         let uri = Uri "file://"
-         uriToFilePath' uri @?= Just ""
-     , testCase "Key with empty file path roundtrips via Binary"  $
-         Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath)
-     , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do
-         let diag = ("", Diagnostics.ShowDiag, Diagnostic
-               { _range = Range
-                   { _start = Position{_line = 0, _character = 1}
-                   , _end = Position{_line = 2, _character = 3}
-                   }
-               , _severity = Nothing
-               , _code = Nothing
-               , _source = Nothing
-               , _message = ""
-               , _relatedInformation = Nothing
-               , _tags = Nothing
-               })
-         let shown = T.unpack (Diagnostics.showDiagnostics [diag])
-         let expected = "1:2-3:4"
-         assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $
-             expected `isInfixOf` shown
-     ]
-
-positionMappingTests :: TestTree
-positionMappingTests =
-    testGroup "position mapping"
-        [ testGroup "toCurrent"
-              [ testCase "before" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "ab"
-                    (Position 0 0) @?= PositionExact (Position 0 0)
-              , testCase "after, same line, same length" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "ab"
-                    (Position 0 3) @?= PositionExact (Position 0 3)
-              , testCase "after, same line, increased length" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc"
-                    (Position 0 3) @?= PositionExact (Position 0 4)
-              , testCase "after, same line, decreased length" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "a"
-                    (Position 0 3) @?= PositionExact (Position 0 2)
-              , testCase "after, next line, no newline" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc"
-                    (Position 1 3) @?= PositionExact (Position 1 3)
-              , testCase "after, next line, newline" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\ndef"
-                    (Position 1 0) @?= PositionExact (Position 2 0)
-              , testCase "after, same line, newline" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\nd"
-                    (Position 0 4) @?= PositionExact (Position 1 2)
-              , testCase "after, same line, newline + newline at end" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\nd\n"
-                    (Position 0 4) @?= PositionExact (Position 2 1)
-              , testCase "after, same line, newline + newline at end" $
-                toCurrent
-                    (Range (Position 0 1) (Position 0 1))
-                    "abc"
-                    (Position 0 1) @?= PositionExact (Position 0 4)
-              ]
-        , testGroup "fromCurrent"
-              [ testCase "before" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "ab"
-                    (Position 0 0) @?= PositionExact (Position 0 0)
-              , testCase "after, same line, same length" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "ab"
-                    (Position 0 3) @?= PositionExact (Position 0 3)
-              , testCase "after, same line, increased length" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc"
-                    (Position 0 4) @?= PositionExact (Position 0 3)
-              , testCase "after, same line, decreased length" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "a"
-                    (Position 0 2) @?= PositionExact (Position 0 3)
-              , testCase "after, next line, no newline" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc"
-                    (Position 1 3) @?= PositionExact (Position 1 3)
-              , testCase "after, next line, newline" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\ndef"
-                    (Position 2 0) @?= PositionExact (Position 1 0)
-              , testCase "after, same line, newline" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\nd"
-                    (Position 1 2) @?= PositionExact (Position 0 4)
-              , testCase "after, same line, newline + newline at end" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 3))
-                    "abc\nd\n"
-                    (Position 2 1) @?= PositionExact (Position 0 4)
-              , testCase "after, same line, newline + newline at end" $
-                fromCurrent
-                    (Range (Position 0 1) (Position 0 1))
-                    "abc"
-                    (Position 0 4) @?= PositionExact (Position 0 1)
-              ]
-        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
-              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
-                -- Note that it is important to use suchThatMap on all values at once
-                -- instead of only using it on the position. Otherwise you can get
-                -- into situations where there is no position that can be mapped back
-                -- for the edit which will result in QuickCheck looping forever.
-                let gen = do
-                        rope <- genRope
-                        range <- genRange rope
-                        PrintableText replacement <- arbitrary
-                        oldPos <- genPosition rope
-                        pure (range, replacement, oldPos)
-                forAll
-                    (suchThatMap gen
-                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
-                    \(range, replacement, oldPos, newPos) ->
-                    fromCurrent range replacement newPos === PositionExact oldPos
-              , testProperty "toCurrent r t <=< fromCurrent r t" $ do
-                let gen = do
-                        rope <- genRope
-                        range <- genRange rope
-                        PrintableText replacement <- arbitrary
-                        let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
-                        newPos <- genPosition newRope
-                        pure (range, replacement, newPos)
-                forAll
-                    (suchThatMap gen
-                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
-                    \(range, replacement, newPos, oldPos) ->
-                    toCurrent range replacement oldPos === PositionExact newPos
-              ]
-        ]
-
-newtype PrintableText = PrintableText { getPrintableText :: T.Text }
-    deriving Show
-
-instance Arbitrary PrintableText where
-    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
-
-
-genRope :: Gen Rope
-genRope = Rope.fromText . getPrintableText <$> arbitrary
-
-genPosition :: Rope -> Gen Position
-genPosition r = do
-    row <- choose (0, max 0 $ rows - 1)
-    let columns = Rope.columns (nthLine row r)
-    column <- choose (0, max 0 $ columns - 1)
-    pure $ Position row column
-    where rows = Rope.rows r
-
-genRange :: Rope -> Gen Range
-genRange r = do
-    startPos@(Position startLine startColumn) <- genPosition r
-    let maxLineDiff = max 0 $ rows - 1 - startLine
-    endLine <- choose (startLine, startLine + maxLineDiff)
-    let columns = Rope.columns (nthLine endLine r)
-    endColumn <-
-        if startLine == endLine
-            then choose (startColumn, columns)
-            else choose (0, max 0 $ columns - 1)
-    pure $ Range startPos (Position endLine endColumn)
-    where rows = Rope.rows r
-
--- | Get the ith line of a rope, starting from 0. Trailing newline not included.
-nthLine :: Int -> Rope -> Rope
-nthLine i r
-    | i < 0 = error $ "Negative line number: " <> show i
-    | i == 0 && Rope.rows r == 0 = r
-    | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
-    | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
-
-getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
-getWatchedFilesSubscriptionsUntil = do
-      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
-      return
-            [ args
-            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
-            , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
-            ]
-
--- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path
--- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or
--- @/var@
-withTempDir :: (FilePath -> IO a) -> IO a
-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
-  dir' <- canonicalizePath dir
-  f dir'
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImplicitParams  #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"++module Main (main) where++import Control.Applicative.Combinators+import Control.Exception (bracket_, catch)+import qualified Control.Lens as Lens+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON, Value, toJSON)+import qualified Data.Binary as Binary+import Data.Default+import Data.Foldable+import Data.List.Extra+import Data.Maybe+import Data.Rope.UTF16 (Rope)+import qualified Data.Rope.UTF16 as Rope+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe)+import Development.IDE.Core.Shake (Q(..))+import Development.IDE.GHC.Util+import qualified Data.Text as T+import Data.Typeable+import Development.IDE.Spans.Common+import Development.IDE.Test+import Development.IDE.Test.Runfiles+import qualified Development.IDE.Types.Diagnostics as Diagnostics+import Development.IDE.Types.Location+import Development.Shake (getDirectoryFilesIO)+import Ide.Plugin.Config+import qualified Experiments as Bench+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)+import Language.Haskell.LSP.VFS (applyChange)+import Network.URI+import System.Environment.Blank (unsetEnv, getEnv, setEnv)+import System.FilePath+import System.IO.Extra hiding (withTempDir)+import qualified System.IO.Extra+import System.Directory+import System.Exit (ExitCode(ExitSuccess))+import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc)+import System.Info.Extra (isWindows)+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.Ingredients.Rerun+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import System.Time.Extra+import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)+import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir))+import Control.Monad.Extra (whenJust)+import qualified Language.Haskell.LSP.Types.Lens as L+import Control.Lens ((^.))++main :: IO ()+main = do+  -- We mess with env vars so run single-threaded.+  defaultMainWithRerun $ testGroup "ghcide"+    [ testSession "open close" $ do+        doc <- createDoc "Testing.hs" "haskell" ""+        void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)+        void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)+        closeDoc doc+        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+    , initializeResponseTests+    , completionTests+    , cppTests+    , diagnosticTests+    , codeActionTests+    , codeLensesTests+    , outlineTests+    , highlightTests+    , findDefinitionAndHoverTests+    , pluginSimpleTests+    , pluginParsedResultTests+    , preprocessorTests+    , thTests+    , safeTests+    , unitTests+    , haddockTests+    , positionMappingTests+    , watchedFilesTests+    , cradleTests+    , dependentFileTest+    , nonLspCommandLine+    , benchmarkTests+    , ifaceTests+    , bootTests+    , rootUriTests+    , asyncTests+    , clientSettingsTest+    , codeActionHelperFunctionTests+    ]++initializeResponseTests :: TestTree+initializeResponseTests = withResource acquire release tests where++  -- these tests document and monitor the evolution of the+  -- capabilities announced by the server in the initialize+  -- response. Currently the server advertises almost no capabilities+  -- at all, in some cases failing to announce capabilities that it+  -- actually does provide! Hopefully this will change ...+  tests :: IO InitializeResponse -> TestTree+  tests getInitializeResponse =+    testGroup "initialize response capabilities"+    [ chk "   text doc sync"             _textDocumentSync  tds+    , chk "   hover"                         _hoverProvider (Just True)+    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)+    , chk "NO signature help"        _signatureHelpProvider  Nothing+    , chk "   goto definition"          _definitionProvider (Just True)+    , chk "   goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True)+    -- BUG in lsp-test, this test fails, just change the accepted response+    -- for now+    , chk "NO goto implementation"  _implementationProvider (Just $ GotoOptionsStatic True)+    , chk "NO find references"          _referencesProvider  Nothing+    , chk "   doc highlight"     _documentHighlightProvider  (Just True)+    , chk "   doc symbol"           _documentSymbolProvider  (Just True)+    , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing+    , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True+    , chk "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions Nothing+    , chk "NO doc formatting"   _documentFormattingProvider  Nothing+    , chk "NO doc range formatting"+                           _documentRangeFormattingProvider  Nothing+    , chk "NO doc formatting on typing"+                          _documentOnTypeFormattingProvider  Nothing+    , chk "NO renaming"                     _renameProvider (Just $ RenameOptionsStatic False)+    , chk "NO doc link"               _documentLinkProvider  Nothing+    , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)+    , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)+    , che "   execute command"      _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])+    , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))+    , chk "NO experimental"                   _experimental  Nothing+    ] where++      tds = Just (TDSOptions (TextDocumentSyncOptions+                              { _openClose = Just True+                              , _change    = Just TdSyncIncremental+                              , _willSave  = Nothing+                              , _willSaveWaitUntil = Nothing+                              , _save = Just (SaveOptions {_includeText = Nothing})}))++      chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree+      chk title getActual expected =+        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir++      che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree+      che title getActual _expected = testCase title doTest+        where+            doTest = do+                ir <- getInitializeResponse+                let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir+                True @=? T.isSuffixOf "typesignature.add" command+++  innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner+  innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c+  innerCaps  _ = error "this test only expects inner capabilities"++  acquire :: IO InitializeResponse+  acquire = run initializeResponse++  release :: InitializeResponse -> IO ()+  release = const $ pure ()+++diagnosticTests :: TestTree+diagnosticTests = testGroup "diagnostics"+  [ testSessionWait "fix syntax error" $ do+      let content = T.unlines [ "module Testing wher" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 19))+            , _rangeLength = Nothing+            , _text = "where"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [])]+  , testSessionWait "introduce syntax error" $ do+      let content = T.unlines [ "module Testing where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)+      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 18))+            , _rangeLength = Nothing+            , _text = "wher"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]+  , testSessionWait "update syntax error" $ do+      let content = T.unlines [ "module Testing(missing) where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])]+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 16))+            , _rangeLength = Nothing+            , _text = "l"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])]+  , testSessionWait "variable not in scope" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> Int -> Int"+            , "foo a _b = a + ab"+            , "bar :: Int -> Int -> Int"+            , "bar _a b = cd + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [ (DsError, (2, 15), "Variable not in scope: ab")+            , (DsError, (4, 11), "Variable not in scope: cd")+            ]+          )+        ]+  , testSessionWait "type error" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String -> Int"+            , "foo a b = a + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]+          )+        ]+  , testSessionWait "typed hole" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String"+            , "foo a = _ a"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]+          )+        ]++  , testGroup "deferral" $+    let sourceA a = T.unlines+          [ "module A where"+          , "a :: Int"+          , "a = " <> a]+        sourceB = T.unlines+          [ "module B where"+          , "import A ()"+          , "b :: Float"+          , "b = True"]+        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"+        expectedDs aMessage =+          [ ("A.hs", [(DsError, (2,4), aMessage)])+          , ("B.hs", [(DsError, (3,4), bMessage)])]+        deferralTest title binding msg = testSessionWait title $ do+          _ <- createDoc "A.hs" "haskell" $ sourceA binding+          _ <- createDoc "B.hs" "haskell"   sourceB+          expectDiagnostics $ expectedDs msg+    in+    [ deferralTest "type error"          "True"    "Couldn't match expected type"+    , deferralTest "typed hole"          "_"       "Found hole"+    , deferralTest "out of scope var"    "unbound" "Variable not in scope"+    ]++  , testSessionWait "remove required module" $ do+      let contentA = T.unlines [ "module ModuleA where" ]+      docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 0) (Position 0 20))+            , _rangeLength = Nothing+            , _text = ""+            }+      changeDoc docA [change]+      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]+  , testSessionWait "add missing module" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      expectDiagnostics [("ModuleB.hs", [])]+  , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do+      -- need to canonicalize in Mac Os+      tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]+  , testSessionWait "cyclic module dependency" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB"+            ]+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics+        [ ( "ModuleA.hs"+          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        , ( "ModuleB.hs"+          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        ]+  , testSessionWait "cyclic module dependency with hs-boot" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import {-# SOURCE #-} ModuleB"+            ]+      let contentB = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures#-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial diagnostic+            , "foo = ()"+            ]+      let contentBboot = T.unlines+            [ "module ModuleB where"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "correct reference used with hs-boot" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import {-# SOURCE #-} ModuleA()"+            ]+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB()"+            , "x = 5"+            ]+      let contentAboot = T.unlines+            [ "module ModuleA where"+            ]+      let contentC = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures #-}"+            , "module ModuleC where"+            , "import ModuleA"+            -- this reference will fail if it gets incorrectly+            -- resolved to the hs-boot file+            , "y = x"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot+      _ <- createDoc "ModuleC.hs" "haskell" contentC+      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "redundant import" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnosticsWithTags+        [ ( "ModuleB.hs"+          , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]+          )+        ]+  , testSessionWait "redundant import even without warning" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial warning for testing purposes+            , "foo = ()"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "package imports" $ do+      let thisDataListContent = T.unlines+            [ "module Data.List where"+            , "x :: Integer"+            , "x = 123"+            ]+      let mainContent = T.unlines+            [ "{-# LANGUAGE PackageImports #-}"+            , "module Main where"+            , "import qualified \"this\" Data.List as ThisList"+            , "import qualified \"base\" Data.List as BaseList"+            , "useThis = ThisList.x"+            , "useBase = BaseList.map"+            , "wrong1 = ThisList.map"+            , "wrong2 = BaseList.x"+            ]+      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent+      _ <- createDoc "Main.hs" "haskell" mainContent+      expectDiagnostics+        [ ( "Main.hs"+          , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")+            ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")+            ]+          )+        ]+  , testSessionWait "unqualified warnings" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+            , "module Foo where"+            , "foo :: Ord a => a -> Int"+            , "foo _a = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+      -- The test is to make sure that warnings contain unqualified names+      -- where appropriate. The warning should use an unqualified name 'Ord', not+      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to+      -- test this is fairly arbitrary.+          , [(DsWarning, (2, 0), "Redundant constraint: Ord a")+            ]+          )+        ]+    , testSessionWait "lower-case drive" $ do+          let aContent = T.unlines+                [ "module A.A where"+                , "import A.B ()"+                ]+              bContent = T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "module A.B where"+                , "import Data.List"+                ]+          uriB <- getDocUri "A/B.hs"+          Just pathB <- pure $ uriToFilePath uriB+          uriB <- pure $+              let (drive, suffix) = splitDrive pathB+              in filePathToUri (joinDrive (lower drive) suffix)+          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)+          liftIO $ writeFileUTF8 pathB $ T.unpack bContent+          uriA <- getDocUri "A/A.hs"+          Just pathA <- pure $ uriToFilePath uriA+          uriA <- pure $+              let (drive, suffix) = splitDrive pathA+              in filePathToUri (joinDrive (lower drive) suffix)+          let itemA = TextDocumentItem uriA "haskell" 0 aContent+          let a = TextDocumentIdentifier uriA+          sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)+          diagsNot <- skipManyTill anyMessage diagnostic+          let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)+          -- Check that if we put a lower-case drive in for A.A+          -- the diagnostics for A.B will also be lower-case.+          liftIO $ fileUri @?= uriB+          let msg = _message (head (toList diags) :: Diagnostic)+          liftIO $ unless ("redundant" `T.isInfixOf` msg) $+              assertFailure ("Expected redundant import but got " <> T.unpack msg)+          closeDoc a+  , testSessionWait "haddock parse error" $ do+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo :: Int"+            , "foo = 1 {-|-}"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (2, 8), "Haddock parse error on input")+            ]+          )+        ]+  , testSessionWait "strip file path" $ do+      let+          name = "Testing"+          content = T.unlines+            [ "module " <> name <> " where"+            , "value :: Maybe ()"+            , "value = [()]"+            ]+      _ <- createDoc (T.unpack name <> ".hs") "haskell" content+      notification <- skipManyTill anyMessage diagnostic+      let+          offenders =+            Lsp.params .+            Lsp.diagnostics .+            Lens.folded .+            Lsp.message .+            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))+          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg+      Lens.mapMOf_ offenders failure notification+  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do+      liftIO $ writeFile (sessionDir </> "hie.yaml")+        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo = ()"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")+            ]+          )+        ]+  , testSessionWait "-Werror in pragma is ignored" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wall -Werror #-}"+            , "module Foo() where"+            , "foo :: Int"+            , "foo = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (3, 0), "Defined but not used:")+            ]+          )+        ]+  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"+        aPath = dir </> "A.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int+    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int++    bdoc <- createDoc bPath "haskell" bSource+    _pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded++    -- Change y from Int to B which introduces a type error in A (imported from P)+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $+                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ]++    -- Open A and edit to fix the type error+    adoc <- createDoc aPath "haskell" aSource+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $+                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]++    expectDiagnostics+      [ ( "P.hs",+          [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),+            (DsWarning, (4, 0), "Top-level binding")+          ]+        ),+        ("A.hs", [])+      ]+    expectNoMoreDiagnostics 1++  , testSessionWait "deduplicate missing module diagnostics" $  do+      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]+      doc <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]++      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]+      expectDiagnostics []++      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines+            [ "module Foo() where" , "import MissingModule" ] ]+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]++  , testGroup "Cancellation"+    [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse  noTc+    , cancellationTestGroup "edit import" editImport noDepends  noSession  yesParse noTc+    , cancellationTestGroup "edit body"   editBody   yesDepends yesSession yesParse yesTc+    ]+  ]+  where+      editPair x y = let p = Position x y ; p' = Position x (y+2) in+        (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}+        ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})+      editHeader = editPair 0 0+      editImport = editPair 2 10+      editBody   = editPair 3 10++      noParse = False+      yesParse = True++      noDepends = False+      yesDepends = True++      noSession = False+      yesSession = True++      noTc = False+      yesTc = True++cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree+cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name+    [ cancellationTemplate edits Nothing+    , cancellationTemplate edits $ Just ("GetFileContents", True)+    , cancellationTemplate edits $ Just ("GhcSession", True)+      -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!)+    , cancellationTemplate edits $ Just ("GetModSummary", True)+    , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)+      -- getLocatedImports never fails+    , cancellationTemplate edits $ Just ("GetLocatedImports", True)+    , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome)+    , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)+    , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)+    , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)+    , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome)+    ]++cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree+cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do+      doc <- createDoc "Foo.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wall #-}"+            , "module Foo where"+            , "import Data.List()"+            , "f0 x = (x,x)"+            ]++      -- for the example above we expect one warning+      let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      -- Now we edit the document and wait for the given key (if any)+      changeDoc doc [edit]+      whenJust mbKey $ \(key, expectedResult) -> do+        Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc+        liftIO $ ideResultSuccess @?= expectedResult++      -- The 2nd edit cancels the active session and unbreaks the file+      -- wait for typecheck and check that the current diagnostics are accurate+      changeDoc doc [undoEdit]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      expectNoMoreDiagnostics 0.5+    where+        -- similar to run except it disables kick+        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s++        typeCheck doc = do+            Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+            liftIO $ assertBool "The file should typecheck" ideResultSuccess+            -- wait for the debouncer to publish diagnostics if the rule runs+            liftIO $ sleep 0.2+            -- flush messages to ensure current diagnostics state is updated+            flushMessages++codeActionTests :: TestTree+codeActionTests = testGroup "code actions"+  [ renameActionTests+  , typeWildCardActionTests+  , removeImportTests+  , extendImportTests+  , suggestImportTests+  , fixConstructorImportTests+  , importRenameActionTests+  , fillTypedHoleTests+  , addSigActionTests+  , insertNewDefinitionTests+  , deleteUnusedDefinitionTests+  , addInstanceConstraintTests+  , addFunctionConstraintTests+  , removeRedundantConstraintsTests+  , addTypeAnnotationsToLiteralsTest+  , exportUnusedTests+  ]++codeActionHelperFunctionTests :: TestTree+codeActionHelperFunctionTests = testGroup "code action helpers"+    [+    extendImportTestsRegEx+    ]+++codeLensesTests :: TestTree+codeLensesTests = testGroup "code lenses"+  [ addSigLensesTests+  ]++watchedFilesTests :: TestTree+watchedFilesTests = testGroup "watched files"+  [ testSession' "workspace files" $ \sessionDir -> do+      liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"+      _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification++      -- Expect 1 subscription: we only ever send one+      liftIO $ length watchedFileRegs @?= 1++  , testSession' "non workspace file" $ \sessionDir -> do+      tmpDir <- liftIO getTemporaryDirectory+      liftIO $ writeFile (sessionDir </> "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}")+      _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification++      -- Expect 1 subscription: we only ever send one+      liftIO $ length watchedFileRegs @?= 1++  -- TODO add a test for didChangeWorkspaceFolder+  ]++renameActionTests :: TestTree+renameActionTests = testGroup "rename actions"+  [ testSession "change to local variable name" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> Int"+            , "foo argName = argNme"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"+      executeCodeAction action+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "foo :: Int -> Int"+            , "foo argName = argName"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "change to name of imported function" $ do+      let content = T.unlines+            [ "module Testing where"+            , "import Data.Maybe (maybeToList)"+            , "foo :: Maybe a -> [a]"+            , "foo = maybToList"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"+      executeCodeAction action+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "import Data.Maybe (maybeToList)"+            , "foo :: Maybe a -> [a]"+            , "foo = maybeToList"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "suggest multiple local variable names" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Char -> Char -> Char -> Char"+            , "foo argument1 argument2 argument3 = argumentX"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))+                           ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]+      return()+  , testSession "change infix function" $ do+      let content = T.unlines+            [ "module Testing where"+            , "monus :: Int -> Int"+            , "monus x y = max 0 (x - y)"+            , "foo x y = x `monnus` y"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))+      [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]+      executeCodeAction fixTypo+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "monus :: Int -> Int"+            , "monus x y = max 0 (x - y)"+            , "foo x y = x `monus` y"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  ]++typeWildCardActionTests :: TestTree+typeWildCardActionTests = testGroup "type wildcard actions"+  [ testSession "global signature" $ do+      let content = T.unlines+            [ "module Testing where"+            , "func :: _"+            , "func x = x"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+                                   , "Use type signature" `T.isInfixOf` actionTitle+                           ]+      executeCodeAction addSignature+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "func :: (p -> p)"+            , "func x = x"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "multi-line message" $ do+      let content = T.unlines+            [ "module Testing where"+            , "func :: _"+            , "func x y = x + y"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+                                    , "Use type signature" `T.isInfixOf` actionTitle+                              ]+      executeCodeAction addSignature+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "func :: (Integer -> Integer -> Integer)"+            , "func x y = x + y"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "local signature" $ do+      let content = T.unlines+            [ "module Testing where"+            , "func :: Int -> Int"+            , "func x ="+            , "  let y :: _"+            , "      y = x * 2"+            , "  in y"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+                                    , "Use type signature" `T.isInfixOf` actionTitle+                              ]+      executeCodeAction addSignature+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "func :: Int -> Int"+            , "func x ="+            , "  let y :: (Int)"+            , "      y = x * 2"+            , "  in y"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  ]++removeImportTests :: TestTree+removeImportTests = testGroup "remove import actions"+  [ testSession "redundant" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "qualified redundant" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant binding" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "stuffA = False"+            , "stuffB :: Integer"+            , "stuffB = 123"+            , "stuffC = ()"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"+            , "main = print stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant operator" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "a !! _b = a"+            , "a <?> _b = a"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"+            , "main = print A.stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove !!, <?> from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import qualified ModuleA as A (stuffB)"+            , "main = print A.stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant all import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data A = A"+            , "stuffB :: Integer"+            , "stuffB = 123"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (A(..), stuffB)"+            , "main = print stuffB"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove A from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (stuffB)"+            , "main = print stuffB"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "redundant constructor import" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "data D = A | B"+            , "data E = F"+            ]+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (D(A,B), E(F))"+            , "main = B"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove A, E, F from import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA (D(B))"+            , "main = B"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "import containing the identifier Strict" $ do+      let contentA = T.unlines+            [ "module Strict where"+            ]+      _docA <- createDoc "Strict.hs" "haskell" contentA+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import Strict"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- waitForDiagnostics+      [CACodeAction action@CodeAction { _title = actionTitle }, _]+          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove import" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  , testSession "remove all" $ do+      let content = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleA where"+            , "import Data.Function (fix, (&))"+            , "import qualified Data.Functor.Const"+            , "import Data.Functor.Identity"+            , "import Data.Functor.Sum (Sum (InL, InR))"+            , "import qualified Data.Kind as K (Constraint, Type)"+            , "x = InL (Identity 123)"+            , "y = fix id"+            , "type T = K.Type"+            ]+      doc <- createDoc "ModuleC.hs" "haskell" content+      _ <- waitForDiagnostics+      [_, _, _, _, CACodeAction action@CodeAction { _title = actionTitle }]+          <- getCodeActions doc (Range (Position 2 0) (Position 2 5))+      liftIO $ "Remove all redundant imports" @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleA where"+            , "import Data.Function (fix)"+            , "import Data.Functor.Identity"+            , "import Data.Functor.Sum (Sum (InL))"+            , "import qualified Data.Kind as K (Type)"+            , "x = InL (Identity 123)"+            , "y = fix id"+            , "type T = K.Type"+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction+  ]++extendImportTests :: TestTree+extendImportTests = testGroup "extend import actions"+  [ testGroup "with checkAll" $ tests True+  , testGroup "without checkAll" $ tests False+  ]+  where+    tests overrideCheckProject =+        [ testSession "extend single line import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB)"+                    , "main = print (stuffA, stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffA, stuffB)"+                    , "main = print (stuffA, stuffB)"+                    ])+        , testSession "extend single line import with operator" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "(.*) :: Integer -> Integer -> Integer"+                    , "x .* y = x * y"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A (stuffB)"+                    , "main = print (stuffB .* stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add (.*) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA as A ((.*), stuffB)"+                    , "main = print (stuffB .* stuffB)"+                    ])+        , testSession "extend single line import with type" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "type A = Double"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA ()"+                    , "b :: A"+                    , "b = 0"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add A to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A)"+                    , "b :: A"+                    , "b = 0"+                    ])+        , testSession "extend single line import with constructor" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = Constructor"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A)"+                    , "b :: A"+                    , "b = Constructor"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add A(Constructor) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A(Constructor))"+                    , "b :: A"+                    , "b = Constructor"+                    ])+        , testSession "extend single line import with mixed constructors" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "data A = ConstructorFoo | ConstructorBar"+                    , "a = 1"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A(ConstructorBar), a)"+                    , "b :: A"+                    , "b = ConstructorFoo"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add A(ConstructorFoo) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (A(ConstructorFoo, ConstructorBar), a)"+                    , "b :: A"+                    , "b = ConstructorFoo"+                    ])+        , testSession "extend single line qualified import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import qualified ModuleA as A (stuffB)"+                    , "main = print (A.stuffA, A.stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import qualified ModuleA as A (stuffA, stuffB)"+                    , "main = print (A.stuffA, A.stuffB)"+                    ])+        , testSession "extend multi line import with value" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "stuffA :: Double"+                    , "stuffA = 0.00750"+                    , "stuffB :: Integer"+                    , "stuffB = 123"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffB"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add stuffA to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (stuffA, stuffB"+                    , "               )"+                    , "main = print (stuffA, stuffB)"+                    ])+        , testSession "extend single line import with method within class" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "class C a where"+                    , "  m1 :: a -> a"+                    , "  m2 :: a -> a"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1))"+                    , "b = m2"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add C(m2) to the import list of ModuleA",+             "Add m2 to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m2, m1))"+                    , "b = m2"+                    ])+        , testSession "extend single line import with method without class" $ template+            [("ModuleA.hs", T.unlines+                    [ "module ModuleA where"+                    , "class C a where"+                    , "  m1 :: a -> a"+                    , "  m2 :: a -> a"+                    ])]+            ("ModuleB.hs", T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (C(m1))"+                    , "b = m2"+                    ])+            (Range (Position 2 5) (Position 2 5))+            ["Add m2 to the import list of ModuleA",+             "Add C(m2) to the import list of ModuleA"]+            (T.unlines+                    [ "module ModuleB where"+                    , "import ModuleA (m2, C(m1))"+                    , "b = m2"+                    ])+        , testSession "extend import list with multiple choices" $ template+            [("ModuleA.hs", T.unlines+                    --  this is just a dummy module to help the arguments needed for this test+                    [  "module ModuleA (bar) where"+                    , "bar = 10"+                    ]),+            ("ModuleB.hs", T.unlines+                    --  this is just a dummy module to help the arguments needed for this test+                    [  "module ModuleB (bar) where"+                    , "bar = 10"+                    ])]+            ("ModuleC.hs", T.unlines+                    [ "module ModuleC where"+                    , "import ModuleB ()"+                    , "import ModuleA ()"+                    , "foo = bar"+                    ])+            (Range (Position 3 17) (Position 3 18))+            ["Add bar to the import list of ModuleA",+            "Add bar to the import list of ModuleB"]+            (T.unlines+                    [ "module ModuleC where"+                    , "import ModuleB ()"+                    , "import ModuleA (bar)"+                    , "foo = bar"+                    ])+        ]+      where+        codeActionTitle CodeAction{_title=x} = x++        template setUpModules moduleUnderTest range expectedTitles expectedContentB = do+            sendNotification WorkspaceDidChangeConfiguration+                (DidChangeConfigurationParams $ toJSON+                  def{checkProject = overrideCheckProject})+++            mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules+            docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)+            _  <- waitForDiagnostics+            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+            actionsOrCommands <- getCodeActions docB range+            let codeActions =+                  filter+                    (T.isPrefixOf "Add" . codeActionTitle)+                    [ca | CACodeAction ca <- actionsOrCommands]+                actualTitles = codeActionTitle <$> codeActions+            -- Note that we are not testing the order of the actions, as the+            -- order of the expected actions indicates which one we'll execute+            -- in this test, i.e., the first one.+            liftIO $ sort expectedTitles @=? sort actualTitles++            -- Execute the action with the same title as the first expected one.+            -- Since we tested that both lists have the same elements (possibly+            -- in a different order), this search cannot fail.+            let firstTitle:_ = expectedTitles+                action = fromJust $+                  find ((firstTitle ==) . codeActionTitle) codeActions+            executeCodeAction action+            contentAfterAction <- documentContents docB+            liftIO $ expectedContentB @=? contentAfterAction++extendImportTestsRegEx :: TestTree+extendImportTestsRegEx = testGroup "regex parsing"+    [+      testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing+    , testCase "parse malformed import list" $ template+                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"+                  Nothing+    , testCase "parse multiple imports" $ template+                 "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"+                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])+    ]+    where+        template message expected = do+            liftIO $ matchRegExMultipleImports message @=? expected++++suggestImportTests :: TestTree+suggestImportTests = testGroup "suggest import actions"+  [ testGroup "Dont want suggestion"+    [ -- extend import+      test False ["Data.List.NonEmpty ()"] "f = nonEmpty" []                "import Data.List.NonEmpty (nonEmpty)"+      -- data constructor+    , test False []                        "f = First"    []                "import Data.Monoid (First)"+      -- internal module+    , test False []         "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable.Internal (Typeable)"+      -- package not in scope+    , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"+      -- don't omit the parent data type of a constructor+    , test False []         "f ExitSuccess = ()"          []                "import System.Exit (ExitSuccess)"+    ]+  , testGroup "want suggestion"+    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"+    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"+    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"+    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"+    , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"+    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"+    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"+    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"+    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"+    , test True []          "f = First"                   []                "import Data.Monoid (First(First))"+    , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"+    , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"+    , test True []          "f ExitSuccess = ()"          []                "import System.Exit (ExitCode(ExitSuccess))"+    , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"+    , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"+    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"+    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"+    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"+    , test True []          "f = empty"                   []                "import Control.Applicative (empty)"+    , test True []          "f = empty"                   []                "import Control.Applicative"+    , test True []          "f = (&)"                     []                "import Data.Function ((&))"+    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"+    , test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"+    , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"+    , test True []          "f = pack"                    []                "import Data.Text (pack)"+    , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"+    , test True []          "f = [] & id"                 []                "import Data.Function ((&))"+    , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"+    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"+    , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"+    ]+  ]+  where+    test = test' False+    wantWait = test' True True+    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do+      let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other+          after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other+          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"+      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle+      doc <- createDoc "Test.hs" "haskell" before+      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+      _diags <- waitForDiagnostics+      -- there isn't a good way to wait until the whole project is checked atm+      when waitForCheckProject $ liftIO $ sleep 0.5+      let defLine = length imps + 1+          range = Range (Position defLine 0) (Position defLine maxBound)+      actions <- getCodeActions doc range+      if wanted+         then do+             action <- liftIO $ pickActionWithTitle newImp actions+             executeCodeAction action+             contentAfterAction <- documentContents doc+             liftIO $ after @=? contentAfterAction+          else+              liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []++insertNewDefinitionTests :: TestTree+insertNewDefinitionTests = testGroup "insert new definition actions"+  [ testSession "insert new function definition" $ do+      let txtB =+            ["foo True = select [True]"+            , ""+            ,"foo False = False"+            ]+          txtB' =+            [""+            ,"someOtherCode = ()"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+      _ <- waitForDiagnostics+      CACodeAction action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                     getCodeActions docB (R 1 0 1 50)+      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ contentAfterAction @?= T.unlines (txtB +++        [ ""+        , "select :: [Bool] -> Bool"+        , "select = error \"not implemented\""+        ]+        ++ txtB')+  , testSession "define a hole" $ do+      let txtB =+            ["foo True = _select [True]"+            , ""+            ,"foo False = False"+            ]+          txtB' =+            [""+            ,"someOtherCode = ()"+            ]+      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')+      _ <- waitForDiagnostics+      CACodeAction action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                     getCodeActions docB (R 1 0 1 50)+      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ contentAfterAction @?= T.unlines (+        ["foo True = select [True]"+        , ""+        ,"foo False = False"+        , ""+        , "select :: [Bool] -> Bool"+        , "select = error \"not implemented\""+        ]+        ++ txtB')+  ]+++deleteUnusedDefinitionTests :: TestTree+deleteUnusedDefinitionTests = testGroup "delete unused definition action"+  [ testSession "delete unused top level binding" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+               , "module A (some) where"+               , ""+               , "f :: Int -> Int"+               , "f 1 = let a = 1"+               , "      in a"+               , "f 2 = 2"+               , ""+               , "some = ()"+               ])+    (4, 0)+    "Delete ‘f’"+    (T.unlines [+        "{-# OPTIONS_GHC -Wunused-top-binds #-}"+        , "module A (some) where"+        , ""+        , "some = ()"+        ])++  , testSession "delete unused top level binding defined in infix form" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+               , "module A (some) where"+               , ""+               , "myPlus :: Int -> Int -> Int"+               , "a `myPlus` b = a + b"+               , ""+               , "some = ()"+               ])+    (4, 2)+    "Delete ‘myPlus’"+    (T.unlines [+        "{-# OPTIONS_GHC -Wunused-top-binds #-}"+        , "module A (some) where"+        , ""+        , "some = ()"+      ])+  , testSession "delete unused binding in where clause" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (h, g) where"+               , ""+               , "h :: Int"+               , "h = 3"+               , ""+               , "g :: Int"+               , "g = 6"+               , "  where"+               , "    h :: Int"+               , "    h = 4"+               , ""+               ])+    (10, 4)+    "Delete ‘h’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (h, g) where"+               , ""+               , "h :: Int"+               , "h = 3"+               , ""+               , "g :: Int"+               , "g = 6"+               , "  where"+               , ""+               ])+  , testSession "delete unused binding with multi-oneline signatures front" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (b, c) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (4, 0)+    "Delete ‘a’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (b, c) where"+               , ""+               , "b, c :: Int"+               , "b = 4"+               , "c = 5"+               ])+  , testSession "delete unused binding with multi-oneline signatures mid" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, c) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (5, 0)+    "Delete ‘b’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, c) where"+               , ""+               , "a, c :: Int"+               , "a = 3"+               , "c = 5"+               ])+  , testSession "delete unused binding with multi-oneline signatures end" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, b) where"+               , ""+               , "a, b, c :: Int"+               , "a = 3"+               , "b = 4"+               , "c = 5"+               ])+    (6, 0)+    "Delete ‘c’"+    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"+               , "module A (a, b) where"+               , ""+               , "a, b :: Int"+               , "a = 3"+               , "b = 4"+               ])+  ]+  where+    testFor source pos expectedTitle expectedResult = do+      docId <- createDoc "A.hs" "haskell" source+      expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ]++      (action, title) <- extractCodeAction docId "Delete"++      liftIO $ title @?= expectedTitle+      executeCodeAction action+      contentAfterAction <- documentContents docId+      liftIO $ contentAfterAction @?= expectedResult++    extractCodeAction docId actionPrefix = do+      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]+      return (action, actionTitle)++addTypeAnnotationsToLiteralsTest :: TestTree+addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy contraints"+  [+    testSession "add default type to satisfy one contraint" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A (f) where"+               , ""+               , "f = 1"+               ])+    [ (DsWarning, (3, 4), "Defaulting the following constraint") ]+    "Add type annotation ‘Integer’ to ‘1’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A (f) where"+               , ""+               , "f = (1 :: Integer)"+               ])++  , testSession "add default type to satisfy one contraint in nested expressions" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A where"+               , ""+               , "f ="+               , "    let x = 3"+               , "    in x"+               ])+    [ (DsWarning, (4, 12), "Defaulting the following constraint") ]+    "Add type annotation ‘Integer’ to ‘3’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A where"+               , ""+               , "f ="+               , "    let x = (3 :: Integer)"+               , "    in x"+               ])+  , testSession "add default type to satisfy one contraint in more nested expressions" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A where"+               , ""+               , "f ="+               , "    let x = let y = 5 in y"+               , "    in x"+               ])+    [ (DsWarning, (4, 20), "Defaulting the following constraint") ]+    "Add type annotation ‘Integer’ to ‘5’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "module A where"+               , ""+               , "f ="+               , "    let x = let y = (5 :: Integer) in y"+               , "    in x"+               ])+  , testSession "add default type to satisfy one contraint with duplicate literals" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f = seq \"debug\" traceShow \"debug\""+               ])+    [ (DsWarning, (6, 8), "Defaulting the following constraint")+    , (DsWarning, (6, 16), "Defaulting the following constraint")+    ]+    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f = seq (\"debug\" :: [Char]) traceShow \"debug\""+               ])+  , testSession "add default type to satisfy two contraints" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f a = traceShow \"debug\" a"+               ])+    [ (DsWarning, (6, 6), "Defaulting the following constraint") ]+    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f a = traceShow (\"debug\" :: [Char]) a"+               ])+  , testSession "add default type to satisfy two contraints with duplicate literals" $+    testFor+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"+               ])+    [ (DsWarning, (6, 54), "Defaulting the following constraint") ]+    "Add type annotation ‘[Char]’ to ‘\"debug\"’"+    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"+               , "{-# LANGUAGE OverloadedStrings #-}"+               , "module A (f) where"+               , ""+               , "import Debug.Trace"+               , ""+               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))"+               ])+  ]+  where+    testFor source diag expectedTitle expectedResult = do+      docId <- createDoc "A.hs" "haskell" source+      expectDiagnostics [ ("A.hs", diag) ]++      (action, title) <- extractCodeAction docId "Add type annotation"++      liftIO $ title @?= expectedTitle+      executeCodeAction action+      contentAfterAction <- documentContents docId+      liftIO $ contentAfterAction @?= expectedResult++    extractCodeAction docId actionPrefix = do+      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R 0 0 0 0) [actionPrefix]+      return (action, actionTitle)+++fixConstructorImportTests :: TestTree+fixConstructorImportTests = testGroup "fix import actions"+  [ testSession "fix constructor import" $ template+      (T.unlines+            [ "module ModuleA where"+            , "data A = Constructor"+            ])+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(Constructor)"+            ])+      (Range (Position 1 10) (Position 1 11))+      "Fix import of A(Constructor)"+      (T.unlines+            [ "module ModuleB where"+            , "import ModuleA(A(Constructor))"+            ])+  ]+  where+    template contentA contentB range expectedAction expectedContentB = do+      _docA <- createDoc "ModuleA.hs" "haskell" contentA+      docB  <- createDoc "ModuleB.hs" "haskell" contentB+      _diags <- waitForDiagnostics+      CACodeAction action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                     getCodeActions docB range+      liftIO $ expectedAction @=? actionTitle+      executeCodeAction action+      contentAfterAction <- documentContents docB+      liftIO $ expectedContentB @=? contentAfterAction++importRenameActionTests :: TestTree+importRenameActionTests = testGroup "import rename actions"+  [ testSession "Data.Mape -> Data.Map"   $ check "Map"+  , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where+  check modname = do+      let content = T.unlines+            [ "module Testing where"+            , "import Data.Mape"+            ]+      doc <- createDoc "Testing.hs" "haskell" content+      _ <- waitForDiagnostics+      actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))+      let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]+      executeCodeAction changeToMap+      contentAfterAction <- documentContents doc+      let expectedContentAfterAction = T.unlines+            [ "module Testing where"+            , "import Data." <> modname+            ]+      liftIO $ expectedContentAfterAction @=? contentAfterAction++fillTypedHoleTests :: TestTree+fillTypedHoleTests = let++  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text+  sourceCode a b c = T.unlines+    [ "module Testing where"+      , ""+      , "globalConvert :: Int -> String"+      , "globalConvert = undefined"+      , ""+      , "globalInt :: Int"+      , "globalInt = 3"+      , ""+      , "bar :: Int -> Int -> String"+      , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"+      , "  localConvert = (flip replicate) 'x'"+      , ""+      , "foo :: () -> Int -> String"+      , "foo = undefined"++    ]++  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle+        oldA oldB oldC+        newA newB newC = testSession (T.unpack actionTitle) $ do+    let originalCode = sourceCode oldA oldB oldC+    let expectedCode = sourceCode newA newB newC+    doc <- createDoc "Testing.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))+    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "fill typed holes"+  [ check "replace _ with show"+          "_"    "n" "n"+          "show" "n" "n"++  , check "replace _ with globalConvert"+          "_"             "n" "n"+          "globalConvert" "n" "n"++  , check "replace _convertme with localConvert"+          "_convertme"   "n" "n"+          "localConvert" "n" "n"++  , check "replace _b with globalInt"+          "_a" "_b"        "_c"+          "_a" "globalInt" "_c"++  , check "replace _c with globalInt"+          "_a" "_b"        "_c"+          "_a" "_b" "globalInt"++  , check "replace _c with parameterInt"+          "_a" "_b" "_c"+          "_a" "_b"  "parameterInt"+  , check "replace _ with foo _"+          "_" "n" "n"+          "(foo _)" "n" "n"+  , testSession "replace _toException with E.toException" $ do+      let mkDoc x = T.unlines+            [ "module Testing where"+            , "import qualified Control.Exception as E"+            , "ioToSome :: E.IOException -> E.SomeException"+            , "ioToSome = " <> x ]+      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))+      chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions+      executeCodeAction chosen+      modifiedCode <- documentContents doc+      liftIO $ mkDoc "E.toException" @=? modifiedCode+  ]++addInstanceConstraintTests :: TestTree+addInstanceConstraintTests = let+  missingConstraintSourceCode :: Maybe T.Text -> T.Text+  missingConstraintSourceCode mConstraint =+    let constraint = maybe "" (<> " => ") mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Wrap a = Wrap a"+    , ""+    , "instance " <> constraint <> "Eq (Wrap a) where"+    , "  (Wrap x) == (Wrap y) = x == y"+    ]++  incompleteConstraintSourceCode :: Maybe T.Text -> T.Text+  incompleteConstraintSourceCode mConstraint =+    let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")")  mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "instance " <> constraint <> " => Eq (Pair a b) where"+    , "  (Pair x y) == (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text+  incompleteConstraintSourceCode2 mConstraint =+    let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")")  mConstraint+     in T.unlines+    [ "module Testing where"+    , ""+    , "data Three a b c = Three a b c"+    , ""+    , "instance " <> constraint <> " => Eq (Three a b c) where"+    , "  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"+    ]++  check :: T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do+    doc <- createDoc "Testing.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 68))+    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode++  in testGroup "add instance constraint"+  [ check+    "Add `Eq a` to the context of the instance declaration"+    (missingConstraintSourceCode Nothing)+    (missingConstraintSourceCode $ Just "Eq a")+  , check+    "Add `Eq b` to the context of the instance declaration"+    (incompleteConstraintSourceCode Nothing)+    (incompleteConstraintSourceCode $ Just "Eq b")+  , check+    "Add `Eq c` to the context of the instance declaration"+    (incompleteConstraintSourceCode2 Nothing)+    (incompleteConstraintSourceCode2 $ Just "Eq c")+  ]++addFunctionConstraintTests :: TestTree+addFunctionConstraintTests = let+  missingConstraintSourceCode :: T.Text -> T.Text+  missingConstraintSourceCode constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "eq :: " <> constraint <> "a -> a -> Bool"+    , "eq x y = x == y"+    ]++  missingConstraintWithForAllSourceCode :: T.Text -> T.Text+  missingConstraintWithForAllSourceCode constraint =+    T.unlines+    [ "{-# LANGUAGE ExplicitForAll #-}"+    , "module Testing where"+    , ""+    , "eq :: forall a. " <> constraint <> "a -> a -> Bool"+    , "eq x y = x == y"+    ]++  incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text+  incompleteConstraintWithForAllSourceCode constraint =+    T.unlines+    [ "{-# LANGUAGE ExplicitForAll #-}"+    , "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode :: T.Text -> T.Text+  incompleteConstraintSourceCode constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCode2 :: T.Text -> T.Text+  incompleteConstraintSourceCode2 constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Three a b c = Three a b c"+    , ""+    , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"+    , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"+    ]++  incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text+  incompleteConstraintSourceCodeWithExtraCharsInContext constraint =+    T.unlines+    [ "module Testing where"+    , ""+    , "data Pair a b = Pair a b"+    , ""+    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text+  incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint =+    T.unlines+    [ "module Testing where"+    , "data Pair a b = Pair a b"+    , "eq "+    , "    :: " <> constraint+    , "    => Pair a b -> Pair a b -> Bool"+    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"+    ]++  check :: String -> T.Text -> T.Text -> T.Text -> TestTree+  check testName actionTitle originalCode expectedCode = testSession testName $ do+    doc <- createDoc "Testing.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound))+    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode++  in testGroup "add function constraint"+  [ check+    "no preexisting constraint"+    "Add `Eq a` to the context of the type signature for `eq`"+    (missingConstraintSourceCode "")+    (missingConstraintSourceCode "Eq a => ")+  , check+    "no preexisting constraint, with forall"+    "Add `Eq a` to the context of the type signature for `eq`"+    (missingConstraintWithForAllSourceCode "")+    (missingConstraintWithForAllSourceCode "Eq a => ")+  , check+    "preexisting constraint, no parenthesis"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCode "Eq a")+    (incompleteConstraintSourceCode "(Eq a, Eq b)")+  , check+    "preexisting constraints in parenthesis"+    "Add `Eq c` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCode2 "(Eq a, Eq b)")+    (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)")+  , check+    "preexisting constraints with forall"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintWithForAllSourceCode "Eq a")+    (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)")+  , check+    "preexisting constraint, with extra spaces in context"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCodeWithExtraCharsInContext "( Eq a )")+    (incompleteConstraintSourceCodeWithExtraCharsInContext "(Eq a, Eq b)")+  , check+    "preexisting constraint, with newlines in type signature"+    "Add `Eq b` to the context of the type signature for `eq`"+    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a)")+    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "(Eq a, Eq b)")+  ]++removeRedundantConstraintsTests :: TestTree+removeRedundantConstraintsTests = let+  header =+    [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+    , "module Testing where"+    , ""+    ]++  redundantConstraintsCode :: Maybe T.Text -> T.Text+  redundantConstraintsCode mConstraint =+    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint+      in T.unlines $ header <>+        [ "foo :: " <> constraint <> "a -> a"+        , "foo = id"+        ]++  redundantMixedConstraintsCode :: Maybe T.Text -> T.Text+  redundantMixedConstraintsCode mConstraint =+    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint+      in T.unlines $ header <>+        [ "foo :: " <> constraint <> " => a -> Bool"+        , "foo x = x == 1"+        ]++  typeSignatureSpaces :: T.Text+  typeSignatureSpaces = T.unlines $ header <>+    [ "foo ::  (Num a, Eq a, Monoid a)  => a -> Bool"+    , "foo x = x == 1"+    ]++  typeSignatureMultipleLines :: T.Text+  typeSignatureMultipleLines = T.unlines $ header <>+    [ "foo :: (Num a, Eq a, Monoid a)"+    , "=> a -> Bool"+    , "foo x = x == 1"+    ]++  check :: T.Text -> T.Text -> T.Text -> TestTree+  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do+    doc <- createDoc "Testing.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound))+    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode++  checkPeculiarFormatting :: String -> T.Text -> TestTree+  checkPeculiarFormatting title code = testSession title $ do+    doc <- createDoc "Testing.hs" "haskell" code+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound))+    liftIO $ assertBool "Found some actions" (null actionsOrCommands)++  in testGroup "remove redundant function constraints"+  [ check+    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"+    (redundantConstraintsCode $ Just "Eq a")+    (redundantConstraintsCode Nothing)+  , check+    "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`"+    (redundantConstraintsCode $ Just "(Eq a, Monoid a)")+    (redundantConstraintsCode Nothing)+  , check+    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"+    (redundantMixedConstraintsCode $ Just "Monoid a, Show a")+    (redundantMixedConstraintsCode Nothing)+  , checkPeculiarFormatting+    "should do nothing when constraints contain an arbitrary number of spaces"+    typeSignatureSpaces+  , checkPeculiarFormatting+    "should do nothing when constraints contain line feeds"+    typeSignatureMultipleLines+  ]++addSigActionTests :: TestTree+addSigActionTests = let+  header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"+  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"+  before def     = T.unlines [header, moduleH,      def]+  after' def sig = T.unlines [header, moduleH, sig, def]++  def >:: sig = testSession (T.unpack def) $ do+    let originalCode = before def+    let expectedCode = after' def sig+    doc <- createDoc "Sigs.hs" "haskell" originalCode+    _ <- waitForDiagnostics+    actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))+    chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands+    executeCodeAction chosenAction+    modifiedCode <- documentContents doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "add signature"+    [ "abc = True"              >:: "abc :: Bool"+    , "foo a b = a + b"         >:: "foo :: Num a => a -> a -> a"+    , "bar a b = show $ a + b"  >:: "bar :: (Show a, Num a) => a -> a -> String"+    , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"+    , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"+    , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"+    , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"+    ]++exportUnusedTests :: TestTree+exportUnusedTests = testGroup "export unused actions"+  [ testGroup "don't want suggestion"+    [ testSession "implicit exports" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# OPTIONS_GHC -Wmissing-signatures #-}"+              , "module A where"+              , "foo = id"])+        (R 3 0 3 3)+        "Export ‘foo’"+        Nothing -- codeaction should not be available+    , testSession "not top-level" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# OPTIONS_GHC -Wunused-binds #-}"+              , "module A (foo,bar) where"+              , "foo = ()"+              , "  where bar = ()"+              , "bar = ()"])+        (R 2 0 2 11)+        "Export ‘bar’"+        Nothing+    , testSession "type is exported but not the constructor of same name" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo) where"+              , "data Foo = Foo"])+        (R 2 0 2 8)+        "Export ‘Foo’"+        Nothing -- codeaction should not be available+    , testSession "unused data field" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo(Foo)) where"+              , "data Foo = Foo {foo :: ()}"])+        (R 2 0 2 20)+        "Export ‘foo’"+        Nothing -- codeaction should not be available+    ]+  , testGroup "want suggestion"+    [ testSession "empty exports" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A ("+              , ") where"+              , "foo = id"])+        (R 3 0 3 3)+        "Export ‘foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A ("+              , "foo) where"+              , "foo = id"])+    , testSession "single line explicit exports" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (foo) where"+              , "foo = id"+              , "bar = foo"])+        (R 3 0 3 3)+        "Export ‘bar’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (foo,bar) where"+              , "foo = id"+              , "bar = foo"])+    , testSession "multi line explicit exports" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A"+              , "  ("+              , "    foo) where"+              , "foo = id"+              , "bar = foo"])+        (R 5 0 5 3)+        "Export ‘bar’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A"+              , "  ("+              , "    foo,bar) where"+              , "foo = id"+              , "bar = foo"])+    , testSession "export list ends in comma" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A"+              , "  (foo,"+              , "  ) where"+              , "foo = id"+              , "bar = foo"])+        (R 4 0 4 3)+        "Export ‘bar’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A"+              , "  (foo,"+              , "  bar) where"+              , "foo = id"+              , "bar = foo"])+    , testSession "unused pattern synonym" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE PatternSynonyms #-}"+              , "module A () where"+              , "pattern Foo a <- (a, _)"])+        (R 3 0 3 10)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE PatternSynonyms #-}"+              , "module A (pattern Foo) where"+              , "pattern Foo a <- (a, _)"])+    , testSession "unused data type" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "data Foo = Foo"])+        (R 2 0 2 7)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo(..)) where"+              , "data Foo = Foo"])+    , testSession "unused newtype" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "newtype Foo = Foo ()"])+        (R 2 0 2 10)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo(..)) where"+              , "newtype Foo = Foo ()"])+    , testSession "unused type synonym" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "type Foo = ()"])+        (R 2 0 2 7)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo) where"+              , "type Foo = ()"])+    , testSession "unused type family" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "module A () where"+              , "type family Foo p"])+        (R 3 0 3 15)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "module A (Foo(..)) where"+              , "type family Foo p"])+    , testSession "unused typeclass" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "class Foo a"])+        (R 2 0 2 8)+        "Export ‘Foo’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (Foo(..)) where"+              , "class Foo a"])+    , testSession "infix" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "a `f` b = ()"])+        (R 2 0 2 11)+        "Export ‘f’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A (f) where"+              , "a `f` b = ()"])+   , testSession "function operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A () where"+              , "(<|) = ($)"])+        (R 2 0 2 9)+        "Export ‘<|’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "module A ((<|)) where"+              , "(<|) = ($)"])+    , testSession "type synonym operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "type (:<) = ()"])+        (R 3 0 3 13)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A ((:<)) where"+              , "type (:<) = ()"])+    , testSession "type family operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "type family (:<)"])+        (R 4 0 4 15)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeFamilies #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "type family (:<)"])+    , testSession "typeclass operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "class (:<) a"])+        (R 3 0 3 11)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "class (:<) a"])+    , testSession "newtype operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "newtype (:<) = Foo ()"])+        (R 3 0 3 20)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "newtype (:<) = Foo ()"])+    , testSession "data type operator" $ template+        (T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A () where"+              , "data (:<) = Foo ()"])+        (R 3 0 3 17)+        "Export ‘:<’"+        (Just $ T.unlines+              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"+              , "{-# LANGUAGE TypeOperators #-}"+              , "module A (type (:<)(..)) where"+              , "data (:<) = Foo ()"])+    ]+  ]+    where+      template initialContent range expectedAction expectedContents = do+        doc <- createDoc "A.hs" "haskell" initialContent+        _ <- waitForDiagnostics+        actions <- getCodeActions doc range+        case expectedContents of+          Just content -> do+            action <- liftIO $ pickActionWithTitle expectedAction actions+            executeCodeAction action+            contentAfterAction <- documentContents doc+            liftIO $ content @=? contentAfterAction+          Nothing ->+            liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= []++addSigLensesTests :: TestTree+addSigLensesTests = let+  missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"+  notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"+  moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C"+  other = T.unlines ["f :: Integer -> Integer", "f x = 3"]+  before  withMissing def+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]+  after'  withMissing def sig+    = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]++  sigSession withMissing def sig = testSession (T.unpack def) $ do+    let originalCode = before withMissing def+    let expectedCode = after' withMissing def sig+    doc <- createDoc "Sigs.hs" "haskell" originalCode+    [CodeLens {_command = Just c}] <- getCodeLenses doc+    executeCommand c+    modifiedCode <- getDocumentEdit doc+    liftIO $ expectedCode @=? modifiedCode+  in+  testGroup "add signature"+    [ testGroup title+      [ sigSession enableWarnings "abc = True"              "abc :: Bool"+      , sigSession enableWarnings "foo a b = a + b"         "foo :: Num a => a -> a -> a"+      , sigSession enableWarnings "bar a b = show $ a + b"  "bar :: (Show a, Num a) => a -> a -> String"+      , sigSession enableWarnings "(!!!) a b = a > b"       "(!!!) :: Ord a => a -> a -> Bool"+      , sigSession enableWarnings "a >>>> b = a + b"        "(>>>>) :: Num a => a -> a -> a"+      , sigSession enableWarnings "a `haha` b = a b"        "haha :: (t1 -> t2) -> t1 -> t2"+      , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"+      , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a"+      ]+      | (title, enableWarnings) <-+        [("with warnings enabled", True)+        ,("with warnings disabled", False)+        ]+    ]++checkDefs :: [Location] -> Session [Expect] -> Session ()+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where++  check (ExpectRange expectedRange) = do+    assertNDefinitionsFound 1 defs+    assertRangeCorrect (head defs) expectedRange+  check (ExpectLocation expectedLocation) = do+    assertNDefinitionsFound 1 defs+    liftIO $ do+      canonActualLoc <- canonicalizeLocation (head defs)+      canonExpectedLoc <- canonicalizeLocation expectedLocation+      canonActualLoc @?= canonExpectedLoc+  check ExpectNoDefinitions = do+    assertNDefinitionsFound 0 defs+  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"+  check _ = pure () -- all other expectations not relevant to getDefinition++  assertNDefinitionsFound :: Int -> [a] -> Session ()+  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)++  assertRangeCorrect Location{_range = foundRange} expectedRange =+    liftIO $ expectedRange @=? foundRange++canonicalizeLocation :: Location -> IO Location+canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range++findDefinitionAndHoverTests :: TestTree+findDefinitionAndHoverTests = let++  tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do++    -- Dirty the cache to check that definitions work even in the presence of iface files+    liftIO $ runInDir dir $ do+      let fooPath = dir </> "Foo.hs"+      fooSource <- liftIO $ readFileUtf8 fooPath+      fooDoc <- createDoc fooPath "haskell" fooSource+      _ <- getHover fooDoc $ Position 4 3+      closeDoc fooDoc++    doc <- openTestDataDoc (dir </> sourceFilePath)+    void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+    found <- get doc pos+    check found targetRange++++  checkHover :: Maybe Hover -> Session [Expect] -> Session ()+  checkHover hover expectations = traverse_ check =<< expectations where++    check expected =+      case hover of+        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"+        Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg})+                  ,_range    = rangeInHover } ->+          case expected of+            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover+            _ -> pure () -- all other expectations not relevant to hover+        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover++  extractLineColFromHoverMsg :: T.Text -> [T.Text]+  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")++  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()+  checkHoverRange expectedRange rangeInHover msg =+    let+      lineCol = extractLineColFromHoverMsg msg+      -- looks like hovers use 1-based numbering while definitions use 0-based+      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.+      adjust Position{_line = l, _character = c} =+        Position{_line = l + 1, _character = c + 1}+    in+    case map (read . T.unpack) lineCol of+      [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c+      _     -> liftIO $ assertFailure $+        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>+        "\n but got: " <> show (msg, rangeInHover)++  assertFoundIn :: T.Text -> T.Text -> Assertion+  assertFoundIn part whole = assertBool+    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)+    (part `T.isInfixOf` whole)++  sourceFilePath = T.unpack sourceFileName+  sourceFileName = "GotoHover.hs"++  mkFindTests tests = testGroup "get"+    [ testGroup "definition" $ mapMaybe fst tests+    , testGroup "hover"      $ mapMaybe snd tests+    , checkFileCompiles sourceFilePath $+        expectDiagnostics+          [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ]+    , testGroup "type-definition" typeDefinitionTests ]++  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"+                        , tst (getTypeDefinitions, checkDefs) opL16 (pure [ExpectNoDefinitions]) "Polymorphic variable"]++  test runDef runHover look expect = testM runDef runHover look (return expect)++  testM runDef runHover look expect title =+    ( runDef   $ tst def   look expect title+    , runHover $ tst hover look expect title ) where+      def   = (getDefinitions, checkDefs)+      hover = (getHover      , checkHover)++  -- search locations            expectations on results+  fffL4  = _start fffR     ;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]+  fffL8  = Position 12  4  ;+  fffL14 = Position 18  7  ;+  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"]]+  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"]]+  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"]]+  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]+  lclL33 = Position 37 22+  mclL36 = Position 40  1  ;  mcl    = [mkR  40  0   40 14]+  mclL37 = Position 41  1+  spaceL37 = Position 41  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]+  docL41 = Position 45  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]+                           ;  constr = [ExpectHoverText ["Monad m"]]+  eitL40 = Position 44 28  ;  kindE  = [ExpectHoverText [":: * -> * -> *\n"]]+  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [":: *\n"]]+  tvrL40 = Position 44 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]+  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["7518"]]+  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["'f'"]]+  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]+  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]+  outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]+  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]+  holeL60 = Position 62 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]+  cccL17 = Position 17 16  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]+  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]+  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]+  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]+  in+  mkFindTests+  --      def    hover  look       expect+  [ 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+  , test  yes    yes    dcL7       tcDC          "data constructor record         #1029"+  , test  yes    yes    dcL12      tcDC          "data constructor plain"                -- https://github.com/haskell/ghcide/pull/121+  , test  yes    yes    tcL6       tcData        "type constructor                #1028" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    xtcL5      xtc           "type constructor external   #717,1028"+  , test  broken yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    vvL16      vv            "plain parameter"                       -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    aL18       apmp          "pattern match name"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL16      op            "top-level operator               #713" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL18      opp           "parameter operator"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    b'L19      bp            "name in backticks"                     -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    clL23      cls           "class in instance declaration   #1027"+  , test  yes    yes    clL25      cls           "class in signature              #1027" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    eclL15     ecls          "external class in signature #717,1027"+  , test  yes    yes    dnbL29     dnb           "do-notation   bind              #1073"+  , test  yes    yes    dnbL30     dnb           "do-notation lookup"+  , test  yes    yes    lcbL33     lcb           "listcomp   bind                 #1073"+  , 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_GHC_API_VERSION(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+  , 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"+  , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #1017"+  , test  no     broken intL41     litI          "literal Int  in hover info      #1016"+  , 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"+  , 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"+  ]+  where yes, broken :: (TestTree -> Maybe TestTree)+        yes    = Just -- test should run and pass+        broken = Just . (`xfail` "known broken")+        no = const Nothing -- don't run this test at all+        skip = const Nothing -- unreliable, don't run++checkFileCompiles :: FilePath -> Session () -> TestTree+checkFileCompiles fp diag =+  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do+    void (openTestDataDoc (dir </> fp))+    diag++pluginSimpleTests :: TestTree+pluginSimpleTests =+  ignoreTest8101 "GHC #18070" $+  ignoreInWindowsForGHC88And810 $+  testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do+    _ <- openDoc (dir </> "KnownNat.hs") "haskell"+    liftIO $ writeFile (dir</>"hie.yaml")+      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"++    expectDiagnostics+      [ ( "KnownNat.hs",+          [(DsError, (9, 15), "Variable not in scope: c")]+          )+      ]++pluginParsedResultTests :: TestTree+pluginParsedResultTests =+  ignoreTest8101 "GHC #18070" $+  ignoreInWindowsForGHC88And810 $+  testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do+    _ <- openDoc (dir</> "RecordDot.hs") "haskell"+    expectNoMoreDiagnostics 2++cppTests :: TestTree+cppTests =+  testGroup "cpp"+    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do+        let content =+              T.unlines+                [ "{-# LANGUAGE CPP #-}",+                  "module Testing where",+                  "#ifdef FOO",+                  "foo = 42"+                ]+        -- The error locations differ depending on which C-preprocessor is used.+        -- Some give the column number and others don't (hence -1). Assert either+        -- of them.+        (run $ expectError content (2, -1))+          `catch` ( \e -> do+                      let _ = e :: HUnitFailure+                      run $ expectError content (2, 1)+                  )+    , testSessionWait "cpp-ghcide" $ do+        _ <- createDoc "A.hs" "haskell" $ T.unlines+          ["{-# LANGUAGE CPP #-}"+          ,"main ="+          ,"#ifdef __GHCIDE__"+          ,"  worked"+          ,"#else"+          ,"  failed"+          ,"#endif"+          ]+        expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]+    ]+  where+    expectError :: T.Text -> Cursor -> Session ()+    expectError content cursor = do+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs",+            [(DsError, cursor, "error: unterminated")]+          )+        ]+      expectNoMoreDiagnostics 0.5++preprocessorTests :: TestTree+preprocessorTests = testSessionWait "preprocessor" $ do+  let content =+        T.unlines+          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"+          , "module Testing where"+          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic+          ]+  _ <- createDoc "Testing.hs" "haskell" content+  expectDiagnostics+    [ ( "Testing.hs",+        [(DsError, (2, 8), "Variable not in scope: z")]+      )+    ]+++safeTests :: TestTree+safeTests =+  testGroup+    "SafeHaskell"+    [ -- Test for https://github.com/haskell/ghcide/issues/424+      testSessionWait "load" $ do+        let sourceA =+              T.unlines+                ["{-# LANGUAGE Trustworthy #-}"+                ,"module A where"+                ,"import System.IO.Unsafe"+                ,"import System.IO ()"+                ,"trustWorthyId :: a -> a"+                ,"trustWorthyId i = unsafePerformIO $ do"+                ,"  putStrLn \"I'm safe\""+                ,"  return i"]+            sourceB =+              T.unlines+                ["{-# LANGUAGE Safe #-}"+                ,"module B where"+                ,"import A"+                ,"safeId :: a -> a"+                ,"safeId = trustWorthyId"+                ]++        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectNoMoreDiagnostics 1 ]++thTests :: TestTree+thTests =+  testGroup+    "TemplateHaskell"+    [ -- Test for https://github.com/haskell/ghcide/pull/212+      testSessionWait "load" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module A where",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "a :: Integer",+                  "a = $(litE $ IntegerL 3)"+                ]+            sourceB =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module B where",+                  "import A",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "b :: Integer",+                  "b = $(litE $ IntegerL $ a) + n"+                ]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]+    , testSessionWait "newtype-closure" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE DeriveDataTypeable #-}"+                  ,"{-# LANGUAGE TemplateHaskell #-}"+                  ,"module A (a) where"+                  ,"import Data.Data"+                  ,"import Language.Haskell.TH"+                  ,"newtype A = A () deriving (Data)"+                  ,"a :: ExpQ"+                  ,"a = [| 0 |]"]+        let sourceB =+              T.unlines+                [ "{-# LANGUAGE TemplateHaskell #-}"+                ,"module B where"+                ,"import A"+                ,"b :: Int"+                ,"b = $( a )" ]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        return ()+    , thReloadingTest+    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891+    , thLinkingTest+    , testSessionWait "findsTHIdentifiers" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE TemplateHaskell #-}"+                , "module A (a) where"+                , "a = [| glorifiedID |]"+                , "glorifiedID :: a -> a"+                , "glorifiedID = id" ]+        let sourceB =+              T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "{-# LANGUAGE TemplateHaskell #-}"+                , "module B where"+                , "import A"+                , "main = $a (putStrLn \"success!\")"]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]+    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do++    -- This test defines a TH value with the meaning "data A = A" in A.hs+    -- Loads and export the template in B.hs+    -- And checks wether the constructor A can be loaded in C.hs+    -- This test does not fail when either A and B get manually loaded before C.hs+    -- or when we remove the seemingly unnecessary TH pragma from C.hs++    let cPath = dir </> "C.hs"+    _ <- openDoc cPath "haskell"+    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]+    ]++-- | test that TH is reevaluated on typecheck+thReloadingTest :: TestTree+thReloadingTest = testCase "reloading-th-test" $ runWithExtraFiles "TH" $ \dir -> do++    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"+        cPath = dir </> "THC.hs"++    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]+    bSource <- liftIO $ readFileUtf8 bPath --  $th+    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()++    adoc <- createDoc aPath "haskell" aSource+    bdoc <- createDoc bPath "haskell" bSource+    cdoc <- createDoc cPath "haskell" cSource++    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]++    -- Change th from () to Bool+    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']+    -- generate an artificial warning to avoid timing out if the TH change does not propagate+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]++    -- Check that the change propagates to C+    expectDiagnostics+        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])+        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])+        ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])+        ]++    closeDoc adoc+    closeDoc bdoc+    closeDoc cdoc++thLinkingTest :: TestTree+thLinkingTest = testCase "th-linking-test" $ runWithExtraFiles "TH" $ \dir -> do++    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"++    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]+    bSource <- liftIO $ readFileUtf8 bPath --  $th_a++    adoc <- createDoc aPath "haskell" aSource+    bdoc <- createDoc bPath "haskell" bSource++    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]++    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']++    -- modify b too+    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']++    expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]++    closeDoc adoc+    closeDoc bdoc+++completionTests :: TestTree+completionTests+  = testGroup "completion"+    [ testGroup "non local" nonLocalCompletionTests+    , testGroup "topLevel" topLevelCompletionTests+    , testGroup "local" localCompletionTests+    , testGroup "other" otherCompletionTests+    ]++completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree+completionTest name src pos expected = testSessionWait name $ do+    docId <- createDoc "A.hs" "haskell" (T.unlines src)+    _ <- waitForDiagnostics+    compls <- getCompletions docId pos+    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]+    liftIO $ do+        let emptyToMaybe x = if T.null x then Nothing else Just x+        compls' @?= [ (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)+            when expectedDocs $+                assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)++topLevelCompletionTests :: [TestTree]+topLevelCompletionTests = [+    completionTest+        "variable"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing),+         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)+        ],+    completionTest+        "constructor"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing),+         ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)+        ],+    completionTest+        "class method"+        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing)],+    completionTest+        "type"+        ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 9)+        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],+    completionTest+        "class"+        ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]+        (Position 0 9)+        [("Xxx", CiClass, "Xxx", False, True, Nothing)],+    completionTest+        "records"+        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]+        (Position 1 19)+        [("_personName", CiFunction, "_personName", False, True, Nothing),+         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],+    completionTest+        "recordsConstructor"+        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]+        (Position 1 19)+        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),+         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]+    ]++localCompletionTests :: [TestTree]+localCompletionTests = [+    completionTest+        "argument"+        ["bar (Just abcdef) abcdefg = abcd"]+        (Position 0 32)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "let"+        ["bar = let (Just abcdef) = undefined"+        ,"          abcdefg = let abcd = undefined in undefined"+        ,"        in abcd"+        ]+        (Position 2 15)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "where"+        ["bar = abcd"+        ,"  where (Just abcdef) = undefined"+        ,"        abcdefg = let abcd = undefined in undefined"+        ]+        (Position 0 10)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "do/1"+        ["bar = do"+        ,"  Just abcdef <- undefined"+        ,"  abcd"+        ,"  abcdefg <- undefined"+        ,"  pure ()"+        ]+        (Position 2 6)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing)+        ],+    completionTest+        "do/2"+        ["bar abcde = do"+        ,"    Just [(abcdef,_)] <- undefined"+        ,"    abcdefg <- undefined"+        ,"    let abcdefgh = undefined"+        ,"        (Just [abcdefghi]) = undefined"+        ,"    abcd"+        ,"  where"+        ,"    abcdefghij = undefined"+        ]+        (Position 5 8)+        [("abcde", CiFunction, "abcde", True, False, Nothing)+        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)+        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)+        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)+        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)+        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)+        ]+    ]++nonLocalCompletionTests :: [TestTree]+nonLocalCompletionTests =+  [ completionTest+      "variable"+      ["module A where", "f = hea"]+      (Position 1 7)+      [("head", CiFunction, "head ${1:[a]}", True, True, Nothing)],+    completionTest+      "constructor"+      ["module A where", "f = Tru"]+      (Position 1 7)+      [ ("True", CiConstructor, "True ", True, True, Nothing),+        ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)+      ],+    completionTest+      "type"+      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]+      (Position 2 7)+      [ ("Bounded", CiClass, "Bounded ${1:*}", True, True, Nothing),+        ("Bool", CiStruct, "Bool ", True, True, Nothing)+      ],+    completionTest+      "qualified"+      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]+      (Position 2 15)+      [ ("head", CiFunction, "head ${1:[a]}", True, True, Nothing)+      ],+    completionTest+      "duplicate import"+      ["module A where", "import Data.List", "import Data.List", "f = perm"]+      (Position 3 8)+      [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing)+      ],+    completionTest+       "dont show hidden items"+       [ "{-# LANGUAGE NoImplicitPrelude #-}",+         "module A where",+         "import Control.Monad hiding (join)",+         "f = joi"+       ]+       (Position 3 6)+       [],+    expectFailBecause "Auto import completion snippets were disabled in v0.6.0.2" $+      testGroup "auto import snippets"+      [ completionTest+        "show imports not in list - simple"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (msum)", "f = joi"]+        (Position 3 6)+        [("join", CiFunction, "join ${1:m (m a)}", False, False,+            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 26}, _end = Position {_line = 2, _character = 26}}, _newText = "join, "}]))]+      , completionTest+        "show imports not in list - multi-line"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import Control.Monad (\n    msum)", "f = joi"]+        (Position 4 6)+        [("join", CiFunction, "join ${1:m (m a)}", False, False,+            Just (List [TextEdit {_range = Range {_start = Position {_line = 3, _character = 8}, _end = Position {_line = 3, _character = 8}}, _newText = "join, "}]))]+      , completionTest+        "show imports not in list - names with _"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import qualified Control.Monad as M (msum)", "f = M.mapM_"]+        (Position 3 11)+        [("mapM_", CiFunction, "mapM_ ${1:a -> m b} ${2:t a}", False, False,+            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 41}, _end = Position {_line = 2, _character = 41}}, _newText = "mapM_, "}]))]+      , completionTest+        "show imports not in list - initial empty list"+        ["{-# LANGUAGE NoImplicitPrelude #-}",+        "module A where", "import qualified Control.Monad as M ()", "f = M.joi"]+        (Position 3 10)+        [("join", CiFunction, "join ${1:m (m a)}", False, False,+            Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 37}, _end = Position {_line = 2, _character = 37}}, _newText = "join, "}]))]+      , completionTest+        "record snippet on import"+        ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"]+        (Position 2 10)+        [("FormatParse", CiStruct, "FormatParse ", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),+        ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])),+        ("FormatParse", CiSnippet, "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False,+        Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}]))+        ]+      ],+      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls+     completionTest+      "do not show pragma completions"+      [ "{-# LANGUAGE  ",+        "{module A where}",+        "main = return ()"+      ]+      (Position 0 13)+      []+  ]++otherCompletionTests :: [TestTree]+otherCompletionTests = [+    completionTest+      "keyword"+      ["module A where", "f = newty"]+      (Position 1 9)+      [("newtype", CiKeyword, "", False, False, Nothing)],+    completionTest+      "type context"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}",+        "module A () where",+        "f = f",+        "g :: Intege"+      ]+      -- At this point the module parses but does not typecheck.+      -- This should be sufficient to detect that we are in a+      -- type context and only show the completion to the type.+      (Position 3 11)+      [("Integer", CiStruct, "Integer ", True, True, Nothing)]+  ]++highlightTests :: TestTree+highlightTests = testGroup "highlight"+  [ testSessionWait "value" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 3 2)+    liftIO $ highlights @?=+            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)+            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)+            , DocumentHighlight (R 4 6 4 9) (Just HkRead)+            , DocumentHighlight (R 5 22 5 25) (Just HkRead)+            ]+  , testSessionWait "type" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 2 8)+    liftIO $ highlights @?=+            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)+            , DocumentHighlight (R 3 11 3 14) (Just HkRead)+            ]+  , testSessionWait "local" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 6 5)+    liftIO $ highlights @?=+            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)+            , DocumentHighlight (R 6 10 6 13) (Just HkRead)+            , DocumentHighlight (R 7 12 7 15) (Just HkRead)+            ]+  , testSessionWait "record" $ do+    doc <- createDoc "A.hs" "haskell" recsource+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 4 15)+    liftIO $ highlights @?=+      -- Span is just the .. on 8.10, but Rec{..} before+#if MIN_GHC_API_VERSION(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 @?=+            [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)+      -- Span is just the .. on 8.10, but Rec{..} before+#if MIN_GHC_API_VERSION(8,10,0)+            , DocumentHighlight (R 4 8 4 10) (Just HkRead)+#else+            , DocumentHighlight (R 4 4 4 11) (Just HkRead)+#endif+            ]+  ]+  where+    source = T.unlines+      ["{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"+      ,"foo :: Int"+      ,"foo = 3 :: Int"+      ,"bar = foo"+      ,"  where baz = let x = foo in x"+      ,"baz arg = arg + x"+      ,"  where x = arg"+      ]+    recsource = T.unlines+      ["{-# LANGUAGE RecordWildCards #-}"+      ,"{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"+      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"+      ,"foo Rec{..} = field2 + field1"+      ]++outlineTests :: TestTree+outlineTests = testGroup+  "outline"+  [ testSessionWait "type class" $ do+    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ moduleSymbol+          "A"+          (R 0 7 0 8)+          [ classSymbol "A a"+                        (R 1 0 1 30)+                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]+          ]+      ]+  , testSessionWait "type class instance " $ do+    let source = T.unlines ["class A a where", "instance A () where"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ classSymbol "A a" (R 0 0 0 15) []+      , docSymbol "A ()" SkInterface (R 1 0 1 19)+      ]+  , testSessionWait "type family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]+  , testSessionWait "type family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "type family A a"+          , "type instance A () = ()"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "type family" SkClass     (R 1 0 1 15)+      , docSymbol "A ()" SkInterface (R 2 0 2 23)+      ]+  , testSessionWait "data family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]+  , testSessionWait "data family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "data family A a"+          , "data instance A () = A ()"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "data family" SkClass     (R 1 0 1 11)+      , docSymbol "A ()" SkInterface (R 2 0 2 25)+      ]+  , testSessionWait "constant" $ do+    let source = T.unlines ["a = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a" SkFunction (R 0 0 0 6)]+  , testSessionWait "pattern" $ do+    let source = T.unlines ["Just foo = Just 21"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]+  , testSessionWait "pattern with type signature" $ do+    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]+  , testSessionWait "function" $ do+    let source = T.unlines ["a _x = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)]+  , testSessionWait "type synonym" $ do+    let source = T.unlines ["type A = Bool"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]+  , testSessionWait "datatype" $ do+    let source = T.unlines ["data A = C"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolWithChildren "A"+                              SkStruct+                              (R 0 0 0 10)+                              [docSymbol "C" SkConstructor (R 0 9 0 10)]+      ]+  , testSessionWait "record fields" $ do+    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @=? Left+      [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)+          [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)+            [ docSymbol "x" SkField (R 1 2 1 3)+            , docSymbol "y" SkField (R 2 4 2 5)+            ]+          ]+      ]+  , testSessionWait "import" $ do+    let source = T.unlines ["import Data.Maybe ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbolWithChildren "imports"+                             SkModule+                             (R 0 0 0 20)+                             [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20)+                             ]+      ]+  , testSessionWait "multiple import" $ do+    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbolWithChildren "imports"+                             SkModule+                             (R 1 0 3 27)+                             [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20)+                             , docSymbol "import Control.Exception" SkModule (R 3 0 3 27)+                             ]+      ]+  , testSessionWait "foreign import" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign import ccall \"a\" a :: Int"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]+  , testSessionWait "foreign export" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign export ccall odd :: Int -> Bool"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]+  ]+ where+  docSymbol name kind loc =+    DocumentSymbol name Nothing kind Nothing loc loc Nothing+  docSymbol' name kind loc selectionLoc =+    DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing+  docSymbolD name detail kind loc =+    DocumentSymbol name (Just detail) kind Nothing loc loc Nothing+  docSymbolWithChildren name kind loc cc =+    DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)+  docSymbolWithChildren' name kind loc selectionLoc cc =+    DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)+  moduleSymbol name loc cc = DocumentSymbol name+                                            Nothing+                                            SkFile+                                            Nothing+                                            (R 0 0 maxBound 0)+                                            loc+                                            (Just $ List cc)+  classSymbol name loc cc = DocumentSymbol name+                                           (Just "class")+                                           SkClass+                                           Nothing+                                           loc+                                           loc+                                           (Just $ List cc)++pattern R :: Int -> Int -> Int -> Int -> Range+pattern R x y x' y' = Range (Position x y) (Position x' y')++xfail :: TestTree -> String -> TestTree+xfail = flip expectFailBecause++ignoreTest8101 :: String -> TestTree -> TestTree+ignoreTest8101+  | GHC_API_VERSION == ("8.10.1" :: String) = ignoreTestBecause+  | otherwise = const id++ignoreInWindowsBecause :: String -> TestTree -> TestTree+ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x)++ignoreInWindowsForGHC88And810 :: TestTree -> TestTree+#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0)+ignoreInWindowsForGHC88And810 =+    ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10"+#else+ignoreInWindowsForGHC88And810 = id+#endif++ignoreInWindowsForGHC88 :: TestTree -> TestTree+#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1)+ignoreInWindowsForGHC88 =+    ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8"+#else+ignoreInWindowsForGHC88 = id+#endif++data Expect+  = ExpectRange Range -- Both gotoDef and hover should report this range+  | ExpectLocation Location+--  | ExpectDefRange Range -- Only gotoDef should report this range+  | ExpectHoverRange Range -- Only hover should report this range+  | ExpectHoverText [T.Text] -- the hover message must contain these snippets+  | ExpectExternFail -- definition lookup in other file expected to fail+  | ExpectNoDefinitions+  | ExpectNoHover+--  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples+  deriving Eq++mkR :: Int -> Int -> Int -> Int -> Expect+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn++mkL :: Uri -> Int -> Int -> Int -> Int -> Expect+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn++haddockTests :: TestTree+haddockTests+  = testGroup "haddock"+      [ testCase "Num" $ checkHaddock+          (unlines+             [ "However, '(+)' and '(*)' are"+             , "customarily expected to define a ring and have the following properties:"+             , ""+             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"+             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"+             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"+             ]+          )+          (unlines+             [ ""+             , ""+             , "However,  `(+)`  and  `(*)`  are"+             , "customarily expected to define a ring and have the following properties: "+             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"+             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"+             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"+             ]+          )+      , testCase "unsafePerformIO" $ checkHaddock+          (unlines+             [ "may require"+             , "different precautions:"+             , ""+             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"+             , "        the I\\/O may be performed more than once."+             , ""+             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"+             , "        elimination being performed on the module."+             , ""+             ]+          )+          (unlines+             [ ""+             , ""+             , "may require"+             , "different precautions: "+             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"+             , "  the I/O may be performed more than once."+             , ""+             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"+             , "  elimination being performed on the module."+             , ""+             ]+          )+      ]+  where+    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt++cradleTests :: TestTree+cradleTests = testGroup "cradle"+    [testGroup "dependencies" [sessionDepsArePickedUp]+    ,testGroup "ignore-fatal" [ignoreFatalWarning]+    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]+    ,testGroup "sub-directory"   [simpleSubDirectoryTest]+    ]++loadCradleOnlyonce :: TestTree+loadCradleOnlyonce = testGroup "load cradle only once"+    [ testSession' "implicit" implicit+    , testSession' "direct"   direct+    ]+    where+        direct dir = do+            liftIO $ writeFileUTF8 (dir </> "hie.yaml")+                "cradle: {direct: {arguments: []}}"+            test dir+        implicit dir = test dir+        test _dir = do+            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"+            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            liftIO $ length msgs @?= 1+            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            liftIO $ length msgs @?= 0+            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            liftIO $ length msgs @?= 0++retryFailedCradle :: TestTree+retryFailedCradle = testSession' "retry failed" $ \dir -> do+  -- The false cradle always fails+  let hieContents = "cradle: {bios: {shell: \"false\"}}"+      hiePath = dir </> "hie.yaml"+  liftIO $ writeFile hiePath hieContents+  hieDoc <- createDoc hiePath "yaml" $ T.pack hieContents+  let aPath = dir </> "A.hs"+  doc <- createDoc aPath "haskell" "main = return ()"+  Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess++  -- Fix the cradle and typecheck again+  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"+  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle+  changeDoc+    hieDoc+    [ TextDocumentContentChangeEvent+        { _range = Nothing,+          _rangeLength = Nothing,+          _text = validCradle+        }+    ]++  -- Force a session restart by making an edit, just to dirty the typecheck node+  changeDoc+    doc+    [ TextDocumentContentChangeEvent+        { _range = Just Range {_start = Position 0 0, _end = Position 0 0},+          _rangeLength = Nothing,+          _text = "\n"+        }+    ]++  Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess+++dependentFileTest :: TestTree+dependentFileTest = testGroup "addDependentFile"+    [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test]+    ]+    where+      test dir = do+        -- If the file contains B then no type error+        -- otherwise type error+        liftIO $ writeFile (dir </> "dep-file.txt") "A"+        let fooContent = T.unlines+              [ "{-# LANGUAGE TemplateHaskell #-}"+              , "module Foo where"+              , "import Language.Haskell.TH.Syntax"+              , "foo :: Int"+              , "foo = 1 + $(do"+              , "               qAddDependentFile \"dep-file.txt\""+              , "               f <- qRunIO (readFile \"dep-file.txt\")"+              , "               if f == \"B\" then [| 1 |] else lift f)"+              ]+        let bazContent = T.unlines ["module Baz where", "import Foo ()"]+        _ <-createDoc "Foo.hs" "haskell" fooContent+        doc <- createDoc "Baz.hs" "haskell" bazContent+        expectDiagnostics+          [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]+        -- Now modify the dependent file+        liftIO $ writeFile (dir </> "dep-file.txt") "B"+        let change = TextDocumentContentChangeEvent+              { _range = Just (Range (Position 2 0) (Position 2 6))+              , _rangeLength = Nothing+              , _text = "f = ()"+              }+        -- Modifying Baz will now trigger Foo to be rebuilt as well+        changeDoc doc [change]+        expectDiagnostics [("Foo.hs", [])]+++cradleLoadedMessage :: Session FromServerMessage+cradleLoadedMessage = satisfy $ \case+        NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod+        _ -> False++cradleLoadedMethod :: T.Text+cradleLoadedMethod = "ghcide/cradle/loaded"++ignoreFatalWarning :: TestTree+ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do+    let srcPath = dir </> "IgnoreFatal.hs"+    src <- liftIO $ readFileUtf8 srcPath+    _ <- createDoc srcPath "haskell" src+    expectNoMoreDiagnostics 5++simpleSubDirectoryTest :: TestTree+simpleSubDirectoryTest =+  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do+    let mainPath = dir </> "a/src/Main.hs"+    mainSource <- liftIO $ readFileUtf8 mainPath+    _mdoc <- createDoc mainPath "haskell" mainSource+    expectDiagnosticsWithTags+      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded+      ]+    expectNoMoreDiagnostics 0.5++simpleMultiTest :: TestTree+simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    aSource <- liftIO $ readFileUtf8 aPath+    adoc <- createDoc aPath "haskell" aSource+    Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc+    liftIO $ assertBool "A should typecheck" ideResultSuccess+    bSource <- liftIO $ readFileUtf8 bPath+    bdoc <- createDoc bPath "haskell" bSource+    Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc+    liftIO $ assertBool "B should typecheck" ideResultSuccess+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Like simpleMultiTest but open the files in the other order+simpleMultiTest2 :: TestTree+simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    bSource <- liftIO $ readFileUtf8 bPath+    bdoc <- createDoc bPath "haskell" bSource+    expectNoMoreDiagnostics 10+    aSource <- liftIO $ readFileUtf8 aPath+    (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource+    -- Need to have some delay here or the test fails+    expectNoMoreDiagnostics 10+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL adoc 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++ifaceTests :: TestTree+ifaceTests = testGroup "Interface loading tests"+    [ -- https://github.com/haskell/ghcide/pull/645/+      ifaceErrorTest+    , ifaceErrorTest2+    , ifaceErrorTest3+    , ifaceTHTest+    ]++bootTests :: TestTree+bootTests = testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do+  let cPath = dir </> "C.hs"+  cSource <- liftIO $ readFileUtf8 cPath++  -- Dirty the cache+  liftIO $ runInDir dir $ do+    cDoc <- createDoc cPath "haskell" cSource+    _ <- getHover cDoc $ Position 4 3+    closeDoc cDoc++  cdoc <- createDoc cPath "haskell" cSource+  locs <- getDefinitions cdoc (Position 7 4)+  let floc = mkR 9 0 9 1+  checkDefs locs (pure [floc])++-- | test that TH reevaluates across interfaces+ifaceTHTest :: TestTree+ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do+    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"+        cPath = dir </> "THC.hs"++    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()+    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()+    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()++    cdoc <- createDoc cPath "haskell" cSource++    -- Change [TH]a from () to Bool+    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])++    -- Check that the change propogates to C+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]+    expectDiagnostics+      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])+      ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])]+    closeDoc cdoc++ifaceErrorTest :: TestTree+ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    -- save so that we can that the error propogates to A+    sendNotification TextDocumentDidSave (DidSaveTextDocumentParams bdoc)++    -- Check that the error propogates to A+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]+++    -- Check that we wrote the interfaces for B when we saved+    lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath+    res <- skipManyTill anyMessage $ responseForId lid+    liftIO $ case res of+      ResponseMessage{_result=Right hidir} -> do+        hi_exists <- doesFileExist $ hidir </> "B.hi"+        assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists+      _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res++    pdoc <- createDoc pPath "haskell" pSource+    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]+    -- Now in P we have+    -- bar = x :: Int+    -- foo = y :: Bool+    -- HOWEVER, in A...+    -- x = y  :: Int+    -- This is clearly inconsistent, and the expected outcome a bit surprising:+    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics+    --   - P is being typechecked with the last successful artifacts for A.+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])+      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])+      ]+    expectNoMoreDiagnostics 2++ifaceErrorTest2 :: TestTree+ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource+    pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]++    -- Add a new definition to P+    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]+    -- Now in P we have+    -- bar = x :: Int+    -- foo = y :: Bool+    -- HOWEVER, in A...+    -- x = y  :: Int+    expectDiagnostics+    -- As in the other test, P is being typechecked with the last successful artifacts for A+    -- (ot thanks to -fdeferred-type-errors)+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])+      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])+      ]++    expectNoMoreDiagnostics 2++ifaceErrorTest3 :: TestTree+ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]++    -- P should not typecheck, as there are no last valid artifacts for A+    _pdoc <- createDoc pPath "haskell" pSource++    -- In this example the interface file for A should not exist (modulo the cache folder)+    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])+      ]+    expectNoMoreDiagnostics 2++sessionDepsArePickedUp :: TestTree+sessionDepsArePickedUp = testSession'+  "session-deps-are-picked-up"+  $ \dir -> do+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: []}}"+    -- Open without OverloadedStrings and expect an error.+    doc <- createDoc "Foo.hs" "haskell" fooContent+    expectDiagnostics+      [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]+    -- Update hie.yaml to enable OverloadedStrings.+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"+    -- Send change event.+    let change =+          TextDocumentContentChangeEvent+            { _range = Just (Range (Position 4 0) (Position 4 0)),+              _rangeLength = Nothing,+              _text = "\n"+            }+    changeDoc doc [change]+    -- Now no errors.+    expectDiagnostics [("Foo.hs", [])]+  where+    fooContent =+      T.unlines+        [ "module Foo where",+          "import Data.Text",+          "foo :: Text",+          "foo = \"hello\""+        ]++-- A test to ensure that the command line ghcide workflow stays working+nonLspCommandLine :: TestTree+nonLspCommandLine = testGroup "ghcide command line"+  [ testCase "works" $ withTempDir $ \dir -> do+        ghcide <- locateGhcideExecutable+        copyTestDataFiles dir "multi"+        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}++        setEnv "HOME" "/homeless-shelter" False++        (ec, _, _) <- readCreateProcessWithExitCode cmd ""++        ec @=? ExitSuccess+  ]++benchmarkTests :: TestTree+benchmarkTests =+    let ?config = Bench.defConfig+            { Bench.verbosity = Bench.Quiet+            , Bench.repetitions = Just 3+            , Bench.buildTool = Bench.Cabal+            } in+    withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"+    [ testCase (Bench.name e) $ do+        Bench.SetupResult{Bench.benchDir} <- getResource+        res <- Bench.runBench (runInDir benchDir) e+        assertBool "did not successfully complete 5 repetitions" $ Bench.success res+        | e <- Bench.experiments+        , Bench.name e /= "edit" -- the edit experiment does not ever fail+    ]++-- | checks if we use InitializeParams.rootUri for loading session+rootUriTests :: TestTree+rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do+  let bPath = dir </> "dirB/Foo.hs"+  liftIO $ copyTestDataFiles dir "rootUri"+  bSource <- liftIO $ readFileUtf8 bPath+  _ <- createDoc "Foo.hs" "haskell" bSource+  expectNoMoreDiagnostics 0.5+  where+    -- similar to run' except we can configure where to start ghcide and session+    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()+    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)++-- | Test if ghcide asynchronously handles Commands and user Requests+asyncTests :: TestTree+asyncTests = testGroup "async"+    [+      testSession "command" $ do+            -- Execute a command that will block forever+            let req = ExecuteCommandParams blockCommandId Nothing Nothing+            void $ sendRequest WorkspaceExecuteCommand req+            -- Load a file and check for code actions. Will only work if the command is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]+    , testSession "request" $ do+            -- Execute a custom request that will block for 1000 seconds+            void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000+            -- Load a file and check for code actions. Will only work if the request is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))+            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]+    ]+++clientSettingsTest :: TestTree+clientSettingsTest = testGroup "client settings handling"+    [+        testSession "ghcide does not support update config" $ do+            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))+            logNot <- skipManyTill anyMessage loggingNotification+            isMessagePresent "Updating Not supported" [getLogMessage logNot]+    ,   testSession "ghcide restarts shake session on config changes" $ do+            void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest+            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))+            nots <- skipManyTill anyMessage $ count 3 loggingNotification+            isMessagePresent "Restarting build session" (map getLogMessage nots)++    ]+  where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg+        getLogMessage _ = ""++        isMessagePresent expectedMsg actualMsgs = liftIO $+            assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs)+                       (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs)+----------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------++testSession :: String -> Session () -> TestTree+testSession name = testCase name . run++testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix++testSession' :: String -> (FilePath -> Session ()) -> TestTree+testSession' name = testCase name . run'++testSessionWait :: String -> Session () -> TestTree+testSessionWait name = testSession name .+      -- Check that any diagnostics produced were already consumed by the test case.+      --+      -- If in future we add test cases where we don't care about checking the diagnostics,+      -- this could move elsewhere.+      --+      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.+      ( >> expectNoMoreDiagnostics 0.5)++pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction+pickActionWithTitle title actions = do+  assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)+  return $ head matches+  where+    titles =+        [ actionTitle+        | CACodeAction CodeAction { _title = actionTitle } <- actions+        ]+    matches =+        [ action+        | CACodeAction action@CodeAction { _title = actionTitle } <- actions+        , title == actionTitle+        ]++mkRange :: Int -> Int -> Int -> Int -> Range+mkRange a b c d = Range (Position a b) (Position c d)++run :: Session a -> IO a+run s = run' (const s)++runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a+runWithExtraFiles prefix s = withTempDir $ \dir -> do+  copyTestDataFiles dir prefix+  runInDir dir (s dir)++copyTestDataFiles :: FilePath -> FilePath -> IO ()+copyTestDataFiles dir prefix = do+  -- Copy all the test data files to the temporary workspace+  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]+  for_ testDataFiles $ \f -> do+    createDirectoryIfMissing True $ dir </> takeDirectory f+    copyFile ("test/data" </> prefix </> f) (dir </> f)++run' :: (FilePath -> Session a) -> IO a+run' s = withTempDir $ \dir -> runInDir dir (s dir)++runInDir :: FilePath -> Session a -> IO a+runInDir dir = runInDir' dir "." "." []++withLongTimeout :: IO a -> IO a+withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")++-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.+runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a+runInDir' dir startExeIn startSessionIn extraOptions s = do+  ghcideExe <- locateGhcideExecutable+  let startDir = dir </> startExeIn+  let projDir = dir </> startSessionIn++  createDirectoryIfMissing True startDir+  createDirectoryIfMissing True projDir+  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56+  -- since the package import test creates "Data/List.hs", which otherwise has no physical home+  createDirectoryIfMissing True $ projDir ++ "/Data"++  let cmd = unwords $+       [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir] ++ extraOptions+  -- HIE calls getXgdDirectory which assumes that HOME is set.+  -- Only sets HOME if it wasn't already set.+  setEnv "HOME" "/homeless-shelter" False+  let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }+  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"+  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"+  let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}+            -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging+            --   { logStdErr = True }+            --   uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages+            --   { logMessages = True }+  runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s+  where+    checkEnv :: String -> IO (Maybe Bool)+    checkEnv s = fmap convertVal <$> getEnv s+    convertVal "0" = False+    convertVal _ = True++openTestDataDoc :: FilePath -> Session TextDocumentIdentifier+openTestDataDoc path = do+  source <- liftIO $ readFileUtf8 $ "test/data" </> path+  createDoc path "haskell" source++findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]+findCodeActions = findCodeActions' (==) "is not a superset of"++findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]+findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of"++findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]+findCodeActions' op errMsg doc range expectedTitles = do+  actions <- getCodeActions doc range+  let matches = sequence+        [ listToMaybe+          [ action+          | CACodeAction action@CodeAction { _title = actionTitle } <- actions+          , expectedTitle `op` actionTitle]+        | expectedTitle <- expectedTitles]+  let msg = show+            [ actionTitle+            | CACodeAction CodeAction { _title = actionTitle } <- actions+            ]+            ++ " " <> errMsg <> " "+            ++ show expectedTitles+  liftIO $ case matches of+    Nothing -> assertFailure msg+    Just _ -> pure ()+  return (fromJust matches)++findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction+findCodeAction doc range t = head <$> findCodeActions doc range [t]++unitTests :: TestTree+unitTests = do+  testGroup "Unit"+     [ testCase "empty file path does NOT work with the empty String literal" $+         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."+     , testCase "empty file path works using toNormalizedFilePath'" $+         uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""+     , testCase "empty path URI" $ do+         Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)+         uriScheme @?= "file:"+         uriPath @?= ""+     , testCase "from empty path URI" $ do+         let uri = Uri "file://"+         uriToFilePath' uri @?= Just ""+     , testCase "Key with empty file path roundtrips via Binary"  $+         Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath)+     , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do+         let diag = ("", Diagnostics.ShowDiag, Diagnostic+               { _range = Range+                   { _start = Position{_line = 0, _character = 1}+                   , _end = Position{_line = 2, _character = 3}+                   }+               , _severity = Nothing+               , _code = Nothing+               , _source = Nothing+               , _message = ""+               , _relatedInformation = Nothing+               , _tags = Nothing+               })+         let shown = T.unpack (Diagnostics.showDiagnostics [diag])+         let expected = "1:2-3:4"+         assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $+             expected `isInfixOf` shown+     ]++positionMappingTests :: TestTree+positionMappingTests =+    testGroup "position mapping"+        [ testGroup "toCurrent"+              [ testCase "before" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= PositionExact (Position 0 0)+              , testCase "after, same line, same length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= PositionExact (Position 0 3)+              , testCase "after, same line, increased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 3) @?= PositionExact (Position 0 4)+              , testCase "after, same line, decreased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 3) @?= PositionExact (Position 0 2)+              , testCase "after, next line, no newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= PositionExact (Position 1 3)+              , testCase "after, next line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 1 0) @?= PositionExact (Position 2 0)+              , testCase "after, same line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 0 4) @?= PositionExact (Position 1 2)+              , testCase "after, same line, newline + newline at end" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd\n"+                    (Position 0 4) @?= PositionExact (Position 2 1)+              , testCase "after, same line, newline + newline at end" $+                toCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 1) @?= PositionExact (Position 0 4)+              ]+        , testGroup "fromCurrent"+              [ testCase "before" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= PositionExact (Position 0 0)+              , testCase "after, same line, same length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= PositionExact (Position 0 3)+              , testCase "after, same line, increased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 4) @?= PositionExact (Position 0 3)+              , testCase "after, same line, decreased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 2) @?= PositionExact (Position 0 3)+              , testCase "after, next line, no newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= PositionExact (Position 1 3)+              , testCase "after, next line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 2 0) @?= PositionExact (Position 1 0)+              , testCase "after, same line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 1 2) @?= PositionExact (Position 0 4)+              , testCase "after, same line, newline + newline at end" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd\n"+                    (Position 2 1) @?= PositionExact (Position 0 4)+              , testCase "after, same line, newline + newline at end" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 4) @?= PositionExact (Position 0 1)+              ]+        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"+              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do+                -- Note that it is important to use suchThatMap on all values at once+                -- instead of only using it on the position. Otherwise you can get+                -- into situations where there is no position that can be mapped back+                -- for the edit which will result in QuickCheck looping forever.+                let gen = do+                        rope <- genRope+                        range <- genRange rope+                        PrintableText replacement <- arbitrary+                        oldPos <- genPosition rope+                        pure (range, replacement, oldPos)+                forAll+                    (suchThatMap gen+                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $+                    \(range, replacement, oldPos, newPos) ->+                    fromCurrent range replacement newPos === PositionExact oldPos+              , testProperty "toCurrent r t <=< fromCurrent r t" $ do+                let gen = do+                        rope <- genRope+                        range <- genRange rope+                        PrintableText replacement <- arbitrary+                        let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)+                        newPos <- genPosition newRope+                        pure (range, replacement, newPos)+                forAll+                    (suchThatMap gen+                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $+                    \(range, replacement, newPos, oldPos) ->+                    toCurrent range replacement oldPos === PositionExact newPos+              ]+        ]++newtype PrintableText = PrintableText { getPrintableText :: T.Text }+    deriving Show++instance Arbitrary PrintableText where+    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary+++genRope :: Gen Rope+genRope = Rope.fromText . getPrintableText <$> arbitrary++genPosition :: Rope -> Gen Position+genPosition r = do+    row <- choose (0, max 0 $ rows - 1)+    let columns = Rope.columns (nthLine row r)+    column <- choose (0, max 0 $ columns - 1)+    pure $ Position row column+    where rows = Rope.rows r++genRange :: Rope -> Gen Range+genRange r = do+    startPos@(Position startLine startColumn) <- genPosition r+    let maxLineDiff = max 0 $ rows - 1 - startLine+    endLine <- choose (startLine, startLine + maxLineDiff)+    let columns = Rope.columns (nthLine endLine r)+    endColumn <-+        if startLine == endLine+            then choose (startColumn, columns)+            else choose (0, max 0 $ columns - 1)+    pure $ Range startPos (Position endLine endColumn)+    where rows = Rope.rows r++-- | Get the ith line of a rope, starting from 0. Trailing newline not included.+nthLine :: Int -> Rope -> Rope+nthLine i r+    | i < 0 = error $ "Negative line number: " <> show i+    | i == 0 && Rope.rows r == 0 = r+    | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)+    | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r++getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]+getWatchedFilesSubscriptionsUntil = do+      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)+      return+            [ args+            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs+            , Registration _id WorkspaceDidChangeWatchedFiles args <- regs+            ]++-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path+-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or+-- @/var@+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir f = System.IO.Extra.withTempDir $ \dir -> do+  dir' <- canonicalizePath dir+  f dir'
test/preprocessor/Main.hs view
@@ -1,10 +1,10 @@-
-module Main(main) where
-
-import System.Environment
-
-main :: IO ()
-main = do
-    _:input:output:_ <- getArgs
-    let f = map (\x -> if x == 'x' then 'y' else x)
-    writeFile output . f =<< readFile input
++module Main(main) where++import System.Environment++main :: IO ()+main = do+    _:input:output:_ <- getArgs+    let f = map (\x -> if x == 'x' then 'y' else x)+    writeFile output . f =<< readFile input
test/src/Development/IDE/Test.hs view
@@ -1,191 +1,191 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.
--- SPDX-License-Identifier: Apache-2.0
-
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module Development.IDE.Test
-  ( Cursor
-  , cursorPosition
-  , requireDiagnostic
-  , diagnostic
-  , expectDiagnostics
-  , expectDiagnosticsWithTags
-  , expectNoMoreDiagnostics
-  , expectCurrentDiagnostics
-  , checkDiagnosticsForDoc
-  , canonicalizeUri
-  , standardizeQuotes
-  , flushMessages
-  , waitForAction
-  ) where
-
-import Control.Applicative.Combinators
-import Control.Lens hiding (List)
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Bifunctor (second)
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as T
-import Language.Haskell.LSP.Test hiding (message)
-import qualified Language.Haskell.LSP.Test as LspTest
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens as Lsp
-import System.Time.Extra
-import Test.Tasty.HUnit
-import System.Directory (canonicalizePath)
-import Data.Maybe (fromJust)
-import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule))
-
-
--- | (0-based line number, 0-based column number)
-type Cursor = (Int, Int)
-
-cursorPosition :: Cursor -> Position
-cursorPosition (line,  col) = Position line col
-
-requireDiagnostic :: 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
-
--- |wait for @timeout@ seconds and report an assertion failure
--- if any diagnostic messages arrive in that period
-expectNoMoreDiagnostics :: Seconds -> Session ()
-expectNoMoreDiagnostics timeout = do
-    -- Give any further diagnostic messages time to arrive.
-    liftIO $ sleep timeout
-    -- Send a dummy message to provoke a response from the server.
-    -- This guarantees that we have at least one message to
-    -- process, so message won't block or timeout.
-    void $ sendRequest (CustomClientMethod "non-existent-method") ()
-    handleMessages
-  where
-    handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers
-    handleDiagnostic = do
-        diagsNot <- LspTest.message :: Session PublishDiagnosticsNotification
-        let fileUri = diagsNot ^. params . uri
-            actual = diagsNot ^. params . diagnostics
-        liftIO $ assertFailure $
-            "Got unexpected diagnostics for " <> show fileUri <>
-            " got " <> show actual
-    ignoreOthers = void anyMessage >> handleMessages
-
-handleCustomMethodResponse :: Session ()
-handleCustomMethodResponse =
-    -- the CustomClientMethod triggers a RspCustomServer
-    -- handle that and then exit
-    void (LspTest.message :: Session CustomResponse)
-
-flushMessages :: Session ()
-flushMessages = do
-    void $ sendRequest (CustomClientMethod "non-existent-method") ()
-    handleCustomMethodResponse <|> ignoreOthers
-    where
-        ignoreOthers = void anyMessage >> flushMessages
-
--- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,
---   only that existing diagnostics have been cleared.
---
---   Rather than trying to assert the absence of diagnostics, introduce an
---   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.
-expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
-expectDiagnostics
-  = expectDiagnosticsWithTags
-  . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))
-
-unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic)
-unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics)
-
-expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()
-expectDiagnosticsWithTags expected = do
-    let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri
-        next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic
-    expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected
-    expectDiagnosticsWithTags' next expected'
-
-expectDiagnosticsWithTags' ::
-  MonadIO m =>
-  m (Uri, List Diagnostic) ->
-  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->
-  m ()
-expectDiagnosticsWithTags' next m | null m = do
-    (_,actual) <- next
-    case actual of
-        List [] ->
-            return ()
-        _ ->
-            liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual
-
-expectDiagnosticsWithTags' next expected = go expected
-  where
-    go m
-      | Map.null m = pure ()
-      | otherwise = do
-        (fileUri, actual) <- next
-        canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri
-        case Map.lookup canonUri m of
-          Nothing -> do
-            liftIO $
-              assertFailure $
-                "Got diagnostics for " <> show fileUri
-                  <> " but only expected diagnostics for "
-                  <> show (Map.keys m)
-                  <> " got "
-                  <> show actual
-          Just expected -> do
-            liftIO $ mapM_ (requireDiagnostic actual) expected
-            liftIO $
-              unless (length expected == length actual) $
-                assertFailure $
-                  "Incorrect number of diagnostics for " <> show fileUri
-                    <> ", expected "
-                    <> show expected
-                    <> " but got "
-                    <> show actual
-            go $ Map.delete canonUri m
-
-expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()
-expectCurrentDiagnostics doc expected = do
-    diags <- getCurrentDiagnostics doc
-    checkDiagnosticsForDoc doc expected diags
-
-checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session ()
-checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do
-    let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)]
-        nuri = toNormalizedUri _uri
-    expectDiagnosticsWithTags' (return $ (_uri, List obtained)) expected'
-
-canonicalizeUri :: Uri -> IO Uri
-canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))
-
-diagnostic :: Session PublishDiagnosticsNotification
-diagnostic = LspTest.message
-
-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
-    waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri)
-    ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId
-    return _result
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++{-# LANGUAGE DuplicateRecordFields #-}++module Development.IDE.Test+  ( Cursor+  , cursorPosition+  , requireDiagnostic+  , diagnostic+  , expectDiagnostics+  , expectDiagnosticsWithTags+  , expectNoMoreDiagnostics+  , expectCurrentDiagnostics+  , checkDiagnosticsForDoc+  , canonicalizeUri+  , standardizeQuotes+  , flushMessages+  , waitForAction+  ) where++import Control.Applicative.Combinators+import Control.Lens hiding (List)+import Control.Monad+import Control.Monad.IO.Class+import Data.Bifunctor (second)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Language.Haskell.LSP.Test hiding (message)+import qualified Language.Haskell.LSP.Test as LspTest+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Lens as Lsp+import System.Time.Extra+import Test.Tasty.HUnit+import System.Directory (canonicalizePath)+import Data.Maybe (fromJust)+import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule))+++-- | (0-based line number, 0-based column number)+type Cursor = (Int, Int)++cursorPosition :: Cursor -> Position+cursorPosition (line,  col) = Position line col++requireDiagnostic :: 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++-- |wait for @timeout@ seconds and report an assertion failure+-- if any diagnostic messages arrive in that period+expectNoMoreDiagnostics :: Seconds -> Session ()+expectNoMoreDiagnostics timeout = do+    -- Give any further diagnostic messages time to arrive.+    liftIO $ sleep timeout+    -- Send a dummy message to provoke a response from the server.+    -- This guarantees that we have at least one message to+    -- process, so message won't block or timeout.+    void $ sendRequest (CustomClientMethod "non-existent-method") ()+    handleMessages+  where+    handleMessages = handleDiagnostic <|> handleCustomMethodResponse <|> ignoreOthers+    handleDiagnostic = do+        diagsNot <- LspTest.message :: Session PublishDiagnosticsNotification+        let fileUri = diagsNot ^. params . uri+            actual = diagsNot ^. params . diagnostics+        liftIO $ assertFailure $+            "Got unexpected diagnostics for " <> show fileUri <>+            " got " <> show actual+    ignoreOthers = void anyMessage >> handleMessages++handleCustomMethodResponse :: Session ()+handleCustomMethodResponse =+    -- the CustomClientMethod triggers a RspCustomServer+    -- handle that and then exit+    void (LspTest.message :: Session CustomResponse)++flushMessages :: Session ()+flushMessages = do+    void $ sendRequest (CustomClientMethod "non-existent-method") ()+    handleCustomMethodResponse <|> ignoreOthers+    where+        ignoreOthers = void anyMessage >> flushMessages++-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,+--   only that existing diagnostics have been cleared.+--+--   Rather than trying to assert the absence of diagnostics, introduce an+--   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.+expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()+expectDiagnostics+  = expectDiagnosticsWithTags+  . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))++unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic)+unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics)++expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()+expectDiagnosticsWithTags expected = do+    let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri+        next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic+    expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected+    expectDiagnosticsWithTags' next expected'++expectDiagnosticsWithTags' ::+  MonadIO m =>+  m (Uri, List Diagnostic) ->+  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->+  m ()+expectDiagnosticsWithTags' next m | null m = do+    (_,actual) <- next+    case actual of+        List [] ->+            return ()+        _ ->+            liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual++expectDiagnosticsWithTags' next expected = go expected+  where+    go m+      | Map.null m = pure ()+      | otherwise = do+        (fileUri, actual) <- next+        canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri+        case Map.lookup canonUri m of+          Nothing -> do+            liftIO $+              assertFailure $+                "Got diagnostics for " <> show fileUri+                  <> " but only expected diagnostics for "+                  <> show (Map.keys m)+                  <> " got "+                  <> show actual+          Just expected -> do+            liftIO $ mapM_ (requireDiagnostic actual) expected+            liftIO $+              unless (length expected == length actual) $+                assertFailure $+                  "Incorrect number of diagnostics for " <> show fileUri+                    <> ", expected "+                    <> show expected+                    <> " but got "+                    <> show actual+            go $ Map.delete canonUri m++expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()+expectCurrentDiagnostics doc expected = do+    diags <- getCurrentDiagnostics doc+    checkDiagnosticsForDoc doc expected diags++checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session ()+checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do+    let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)]+        nuri = toNormalizedUri _uri+    expectDiagnosticsWithTags' (return $ (_uri, List obtained)) expected'++canonicalizeUri :: Uri -> IO Uri+canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))++diagnostic :: Session PublishDiagnosticsNotification+diagnostic = LspTest.message++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+    waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri)+    ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId+    return _result