ghcide 0.0.6 → 0.1.0

raw patch · 39 files changed

+2624/−1665 lines, 39 filesdep +QuickCheckdep +quickcheck-instancesdep +tasty-quickcheckdep ~haddock-librarydep ~haskell-lspdep ~hie-biosPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, quickcheck-instances, tasty-quickcheck

Dependency ranges changed: haddock-library, haskell-lsp, hie-bios, shake

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• README.md +1/−3
• exe/Main.hs +18/−7
• ghcide.cabal +41/−11
• src/Development/IDE/Core/Compile.hs +16/−13
• src/Development/IDE/Core/Completions.hs +0/−539
• src/Development/IDE/Core/CompletionsTypes.hs +0/−62
• src/Development/IDE/Core/Debouncer.hs +5/−4
• src/Development/IDE/Core/FileExists.hs +187/−0
• src/Development/IDE/Core/FileStore.hs +11/−63
• src/Development/IDE/Core/OfInterest.hs +16/−16
• src/Development/IDE/Core/Preprocessor.hs +8/−0
• src/Development/IDE/Core/RuleTypes.hs +1/−11
• src/Development/IDE/Core/Rules.hs +16/−31
• src/Development/IDE/Core/Service.hs +7/−3
• src/Development/IDE/Core/Shake.hs +103/−80
• src/Development/IDE/GHC/CPP.hs +8/−4
• src/Development/IDE/GHC/Compat.hs +0/−15
• src/Development/IDE/GHC/Error.hs +6/−0
• src/Development/IDE/GHC/Util.hs +50/−18
• src/Development/IDE/LSP/CodeAction.hs +0/−467
• src/Development/IDE/LSP/Completions.hs +0/−51
• src/Development/IDE/LSP/HoverDefinition.hs +4/−4
• src/Development/IDE/LSP/LanguageServer.hs +5/−7
• src/Development/IDE/LSP/Notifications.hs +28/−11
• src/Development/IDE/LSP/Outline.hs +3/−3
• src/Development/IDE/LSP/Server.hs +2/−3
• src/Development/IDE/Plugin.hs +34/−0
• src/Development/IDE/Plugin/CodeAction.hs +505/−0
• src/Development/IDE/Plugin/Completions.hs +88/−0
• src/Development/IDE/Plugin/Completions/Logic.hs +534/−0
• src/Development/IDE/Plugin/Completions/Types.hs +58/−0
• src/Development/IDE/Spans/AtPoint.hs +34/−20
• src/Development/IDE/Spans/Calculate.hs +125/−65
• src/Development/IDE/Spans/Common.hs +162/−0
• src/Development/IDE/Spans/Documentation.hs +13/−95
• src/Development/IDE/Spans/Type.hs +18/−3
• src/Development/IDE/Types/Location.hs +44/−8
• test/exe/Main.hs +458/−48

@@ -1,5 +1,20 @@ ### unreleased +### 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

@@ -224,10 +224,8 @@ {   "languageserver": {     "haskell": {-      "command": "stack",+      "command": "ghcide",       "args": [-        "exec",-        "ghcide",         "--lsp"       ],       "rootPatterns": [

@@ -28,6 +28,9 @@ import Development.IDE.Types.Options import Development.IDE.Types.Logger import Development.IDE.GHC.Util+import Development.IDE.Plugin+import Development.IDE.Plugin.Completions as Completions+import Development.IDE.Plugin.CodeAction as CodeAction import qualified Data.Text as T import qualified Data.Text.IO as T import Language.Haskell.LSP.Messages@@ -83,26 +86,30 @@      dir <- getCurrentDirectory +    let plugins = Completions.plugin <> CodeAction.plugin+     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 ghcidie WITHOUT the --lsp option!"-        runLanguageServer def def $ \getLspId event vfs caps -> do+        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"+        runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do             t <- t             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t             -- very important we only call loadSession once, and it's fast, so just do it before starting             session <- loadSession dir             let options = (defaultIdeOptions $ return session)-                    { optReportProgress = clientSupportsProgress caps +                    { optReportProgress = clientSupportsProgress caps                     , optShakeProfiling = argsShakeProfiling                     }-            initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs+            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs     else do         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."         putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"          putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir-        files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])+        files <- expandFiles (argFiles ++ ["." | null argFiles])+        -- LSP works with absolute file paths, so try and behave similarly+        files <- nubOrd <$> mapM canonicalizePath files         putStrLn $ "Found " ++ show (length files) ++ " files"          putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"@@ -125,8 +132,12 @@         let grab file = fromMaybe (head sessions) $ do                 cradle <- Map.lookup file filesToCradles                 Map.lookup cradle cradlesToSessions-        ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs +        let options =+              (defaultIdeOptions $ return $ return . grab)+                    { optShakeProfiling = argsShakeProfiling }+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs+         putStrLn "\nStep 6/6: Type checking the files"         setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files         results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files@@ -166,7 +177,7 @@ showEvent lock e = withLock lock $ print e  -cradleToSession :: Cradle -> IO HscEnvEq+cradleToSession :: Cradle a -> IO HscEnvEq cradleToSession cradle = do     cradleRes <- getCompilerOptions "" cradle     opts <- case cradleRes of

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.0.6+version:            0.1.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset@@ -41,7 +41,7 @@         extra,         fuzzy,         filepath,-        haddock-library,+        haddock-library >= 1.8,         hashable,         haskell-lsp-types == 0.19.*,         haskell-lsp == 0.19.*,@@ -53,7 +53,7 @@         regex-tdfa >= 1.3.1.0,         rope-utf16-splay,         safe-exceptions,-        shake >= 0.17.5,+        shake >= 0.18.4,         sorted-list,         stm,         syb,@@ -99,8 +99,6 @@     include-dirs:         include     exposed-modules:-        Development.IDE.Core.Completions-        Development.IDE.Core.CompletionsTypes         Development.IDE.Core.FileStore         Development.IDE.Core.OfInterest         Development.IDE.Core.PositionMapping@@ -108,27 +106,30 @@         Development.IDE.Core.RuleTypes         Development.IDE.Core.Service         Development.IDE.Core.Shake+        Development.IDE.GHC.Error         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation         Development.IDE.LSP.LanguageServer         Development.IDE.LSP.Protocol         Development.IDE.LSP.Server+        Development.IDE.Spans.Common         Development.IDE.Types.Diagnostics         Development.IDE.Types.Location         Development.IDE.Types.Logger         Development.IDE.Types.Options+        Development.IDE.Plugin+        Development.IDE.Plugin.Completions+        Development.IDE.Plugin.CodeAction     other-modules:         Development.IDE.Core.Debouncer         Development.IDE.Core.Compile         Development.IDE.Core.Preprocessor+        Development.IDE.Core.FileExists         Development.IDE.GHC.Compat         Development.IDE.GHC.CPP-        Development.IDE.GHC.Error         Development.IDE.GHC.Orphans         Development.IDE.GHC.Warnings         Development.IDE.Import.FindImports-        Development.IDE.LSP.CodeAction-        Development.IDE.LSP.Completions         Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.Notifications         Development.IDE.LSP.Outline@@ -136,6 +137,8 @@         Development.IDE.Spans.Calculate         Development.IDE.Spans.Documentation         Development.IDE.Spans.Type+        Development.IDE.Plugin.Completions.Logic+        Development.IDE.Plugin.Completions.Types     ghc-options: -Wall -Wno-name-shadowing  executable ghcide-test-preprocessor@@ -151,7 +154,16 @@       buildable: False     default-language:   Haskell2010     hs-source-dirs:     exe-    ghc-options: -threaded -Wall -Wno-name-shadowing+    ghc-options:+                -threaded+                -Wall+                -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:         hslogger,@@ -165,7 +177,7 @@         ghc,         gitrev,         haskell-lsp,-        hie-bios >= 0.3.2 && < 0.4,+        hie-bios >= 0.4.0 && < 0.5,         ghcide,         optparse-applicative,         shake,@@ -205,13 +217,19 @@         --------------------------------------------------------------         ghcide,         ghc-typelits-knownnat,+        haddock-library,+        haskell-lsp,         haskell-lsp-types,         lens,         lsp-test >= 0.8,         parser-combinators,+        QuickCheck,+        quickcheck-instances,+        rope-utf16-splay,         tasty,-        tasty-hunit,         tasty-expected-failure,+        tasty-hunit,+        tasty-quickcheck,         text     hs-source-dirs: test/cabal test/exe test/src     include-dirs: include@@ -221,4 +239,16 @@         Development.IDE.Test         Development.IDE.Test.Runfiles     default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns         OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns

@@ -20,6 +20,7 @@  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@@ -61,17 +62,19 @@ import           System.FilePath  --- | Given a string buffer, return a pre-processed @ParsedModule@.+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule     :: IdeOptions     -> HscEnv     -> FilePath     -> Maybe SB.StringBuffer-    -> IO ([FileDiagnostic], Maybe ParsedModule)-parseModule IdeOptions{..} env file =-    fmap (either (, Nothing) (second Just)) .-    -- We need packages since imports fail to resolve otherwise.-    runGhcEnv env . runExceptT . parseFileContents optPreprocessor file+    -> IO (IdeResult (StringBuffer, ParsedModule))+parseModule IdeOptions{..} env filename mbContents =+    fmap (either (, Nothing) id) $+    runGhcEnv env $ runExceptT $ do+        (contents, dflags) <- preprocessor filename mbContents+        (diag, modu) <- parseFileContents optPreprocessor dflags filename contents+        return (diag, Just (contents, modu))   -- | Given a package identifier, what packages does it depend on@@ -93,7 +96,7 @@     -> HscEnv     -> [TcModuleResult]     -> ParsedModule-    -> IO ([FileDiagnostic], Maybe TcModuleResult)+    -> IO (IdeResult TcModuleResult) typecheckModule (IdeDefer defer) packageState deps pm =     let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id     in@@ -127,7 +130,7 @@     :: HscEnv     -> [TcModuleResult]     -> TcModuleResult-    -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))+    -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) compileModule packageState deps tmr =     fmap (either (, Nothing) (second Just)) $     runGhcEnv packageState $@@ -146,7 +149,7 @@             (guts, details) <- liftIO $ tidyProgram session desugar             return (map snd warnings, (mg_safe_haskell desugar, guts, details)) -generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable) generateByteCode hscEnv deps tmr guts =     fmap (either (, Nothing) (second Just)) $     runGhcEnv hscEnv $@@ -347,15 +350,15 @@   -- | Given a buffer, flags, file path and module summary, produce a--- parsed module (or errors) and any parse warnings.+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors parseFileContents        :: GhcMonad m        => (GHC.ParsedSource -> IdePreprocessedSource)+       -> DynFlags -- ^ flags to use        -> FilePath  -- ^ the filename (for source locations)-       -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)+       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)-parseFileContents customPreprocessor filename mbContents = do-   (contents, dflags) <- preprocessor filename mbContents+parseFileContents customPreprocessor dflags filename contents = do    let loc  = mkRealSrcLoc (mkFastString filename) 1 1    case unP Parser.parseModule (mkPState dflags contents loc) of      PFailed _ locErr msgErr ->

@@ -1,539 +0,0 @@--- Mostly taken from "haskell-ide-engine"-module Development.IDE.Core.Completions (-  CachedCompletions-, cacheDataProducer-, WithSnippets(..)-,getCompletions-) where--import Control.Applicative-import Data.Char (isSpace, isUpper)-import Data.Generics-import Data.List as List hiding (stripPrefix)-import qualified Data.Map  as Map-import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.Text as T-import qualified Text.Fuzzy as Fuzzy--import GHC-import HscTypes-import Name-import RdrName-import TcRnTypes-import Type-import Var-import Packages-import DynFlags-import ConLike-import DataCon-import SrcLoc as GHC--import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Capabilities-import qualified Language.Haskell.LSP.VFS as VFS-import Development.IDE.Core.CompletionsTypes-import Development.IDE.Spans.Documentation-import Development.IDE.GHC.Util-import Development.IDE.GHC.Error-import Development.IDE.Types.Options---- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs--safeTyThingId :: TyThing -> Maybe Id-safeTyThingId (AnId i)                    = Just i-safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc-safeTyThingId _                           = Nothing--safeTyThingType :: TyThing -> Maybe Type-safeTyThingType thing-  | Just i <- safeTyThingId thing = Just (varType i)-safeTyThingType (ATyCon tycon)    = Just (tyConKind tycon)-safeTyThingType _                 = Nothing---- 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 (RealSrcSpan r) modName) <- moduleHeader-  , pos `isInsideRange` r-  = Just (ModuleContext (moduleNameString modName))--  | Just (L (RealSrcSpan r) _) <- exportList-  , pos `isInsideRange` 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 (RealSrcSpan r) SigD {})-          | pos `isInsideRange` r = Just TypeContext-          | otherwise = Nothing-        go (L (GHC.RealSrcSpan r) GHC.ValD {})-          | pos `isInsideRange` r = Just ValueContext-          | otherwise = Nothing-        go _ = Nothing--        goInline :: GHC.LHsType GhcPs -> Maybe Context-        goInline (GHC.L (GHC.RealSrcSpan r) _)-          | pos `isInsideRange` r = Just TypeContext-          | otherwise = Nothing-        goInline _ = Nothing--        p `isInsideRange` r = sp <= p && p <= ep-          where (sp, ep) = unpackRealSrcSpan r--        -- | Converts from one based tuple-        toPos :: (Int,Int) -> Position-        toPos (l,c) = Position (l-1) (c-1)-          -        unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)-        unpackRealSrcSpan rspan =-          (toPos (l1,c1),toPos (l2,c2))-          where s  = GHC.realSrcSpanStart rspan-                l1 = GHC.srcLocLine s-                c1 = GHC.srcLocCol s-                e  = GHC.realSrcSpanEnd rspan-                l2 = GHC.srcLocLine e-                c2 = GHC.srcLocCol e--        importGo :: GHC.LImportDecl GhcPs -> Maybe Context-        importGo (L (RealSrcSpan r) impDecl)-          | pos `isInsideRange` r-          = importInline importModuleName (ideclHiding impDecl)-          <|> Just (ImportContext importModuleName)--          | otherwise = Nothing-          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl--        importGo _ = Nothing--        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context-        importInline modName (Just (True, L (RealSrcSpan r) _))-          | pos `isInsideRange` r = Just $ ImportHidingContext modName-          | otherwise = Nothing-        importInline modName (Just (False, L (RealSrcSpan r) _))-          | pos `isInsideRange` 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--mkCompl :: IdeOptions -> CompItem -> CompletionItem-mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =-  CompletionItem label kind ((colon <>) <$> typeText)-    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')-    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)-    Nothing Nothing Nothing Nothing Nothing-  where kind = Just $ occNameToComKind typeText $ occName 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-        docs' = ("*Defined in '" <> importedFrom <> "'*\n") : docs-        colon = if optNewColonConvention then ": " else ":: "--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 " " $ zipWith 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)-      | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)-      | otherwise = []--mkModCompl :: T.Text -> CompletionItem-mkModCompl label =-  CompletionItem label (Just CiModule) 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) (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--mkPragmaCompl :: T.Text -> T.Text -> CompletionItem-mkPragmaCompl label insertText =-  CompletionItem label (Just CiKeyword) Nothing-    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)-    Nothing Nothing Nothing Nothing Nothing--cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions-cacheDataProducer packageState dflags tm tcs = do-  let parsedMod = tm_parsed_module tm-      curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod-      Just (_,limports,_,_) = tm_renamed_source tm--      iDeclToModName :: ImportDecl name -> ModuleName-      iDeclToModName = unLoc . ideclName--      showModName :: ModuleName -> T.Text-      showModName = T.pack . moduleNameString--      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--      typeEnv = tcg_type_env $ fst $ tm_internals_ tm-      rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm-      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 _) =-        case lookupTypeEnv typeEnv n of-          Just tt -> case safeTyThingId tt of-            Just var -> (\x -> ([x],mempty)) <$> varToCompl var-            Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n-          Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n-      getComplsForOne (GRE n _ False prov) =-        flip foldMapM (map is_decl prov) $ \spec -> do-          compItem <- toCompItem (is_mod spec) n-          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)--      varToCompl :: Var -> IO CompItem-      varToCompl var = do-        let typ = Just $ varType var-            name = Var.varName var-            label = T.pack $ showGhc name-        docs <- getDocumentationTryGhc packageState (tm:tcs) name-        return $ CI name (showModName curMod) typ label Nothing docs--      toCompItem :: ModuleName -> Name -> IO CompItem-      toCompItem mn n = do-        docs <- getDocumentationTryGhc packageState (tm:tcs) n-        ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do-                name' <- lookupName n-                return $ name' >>= safeTyThingType-        return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs--  (unquals,quals) <- getCompls rdrElts--  return $ CC-    { allModNamesAsNS = allModNamesAsNS-    , unqualCompls = unquals-    , qualCompls = quals-    , importableModules = moduleNames-    }--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 = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)---- | Returns the cached completions for the given module and position.-getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]-getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }-               tm prefixInfo caps withSnippets = do-  let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo-      enteredQual = if T.null prefixModule then "" else prefixModule <> "."-      fullPrefix  = enteredQual <> prefixText--      -- default to value context if no explicit context-      context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)--      {- correct the position by moving 'foo :: Int -> String ->    '-                                                                    ^-          to                             'foo :: Int -> String ->    '-                                                              ^-      -}-      pos =-        let Position l c = VFS.cursorPos prefixInfo-            typeStuff = [isSpace, (`elem` (">-." :: String))]-            stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)-            -- if oldPos points to-            -- foo -> bar -> baz-            --    ^-            -- Then only take the line up to there, discard '-> bar -> baz'-            partialLine = T.take c fullLine-            -- drop characters used when writing incomplete type sigs-            -- like '-> '-            d = T.length fullLine - T.length (stripTypeStuff partialLine)-        in Position l (c - d)--      filtModNameCompls =-        map mkModCompl-          $ mapMaybe (T.stripPrefix enteredQual)-          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS--      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False-        where-          isTypeCompl = isTcOcc . occName . origName-          -- completions specific to the current context-          ctxCompls' = case context of-                        TypeContext -> filter isTypeCompl compls-                        ValueContext -> filter (not . isTypeCompl) compls-                        _ -> 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 (VFS.cursorPos prefixInfo)--          compls = if T.null prefixModule-            then 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--      stripLeading :: Char -> String -> String-      stripLeading _ [] = []-      stripLeading c (s:ss)-        | s == c = ss-        | otherwise = s:ss--      result-        | "import " `T.isPrefixOf` fullLine-        = filtImportCompls-        | "{-# language" `T.isPrefixOf` T.toLower fullLine-        = filtOptsCompls languagesAndExts-        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine-        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)-        | "{-# " `T.isPrefixOf` fullLine-        = filtPragmaCompls (pragmaSuffix fullLine)-        | otherwise-        = filtModNameCompls ++ map (toggleSnippets caps withSnippets-                                      . mkCompl ideOpts . stripAutoGenerated) filtCompls-  -  return result---- The supported languages and extensions-languagesAndExts :: [T.Text]-languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions-  --- ------------------------------------------------------------------------ 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"-  ]

@@ -1,62 +0,0 @@-module Development.IDE.Core.CompletionsTypes (-  module Development.IDE.Core.CompletionsTypes-) where--import           Control.DeepSeq-import qualified Data.Map  as Map-import qualified Data.Text as T--import           GHC-import           Outputable-import           DynFlags---- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs--showGhc :: Outputable a => a -> String-showGhc = showPpr unsafeGlobalDynFlags--data Backtick = Surrounded | LeftSide deriving Show-data CompItem = CI-  { origName     :: Name           -- ^ Original name, such as Maybe, //, or find.-  , importedFrom :: T.Text         -- ^ From where this item is imported from.-  , thingType    :: Maybe Type     -- ^ 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         :: [T.Text]       -- ^ Available documentation.-  }-instance Show CompItem where-  show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""-                   ++ ", importedFrom = " ++ show importedFrom-                   ++ ", thingType = " ++ show (fmap showGhc thingType)-                   ++ ", label = " ++ show label-                   ++ ", isInfix = " ++ show isInfix -                   ++ ", docs = " ++ show docs-                   ++ " } "-instance Eq CompItem where-  ci1 == ci2 = origName ci1 == origName ci2-instance Ord CompItem where-  compare ci1 ci2 = origName ci1 `compare` origName ci2---- 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

@@ -11,8 +11,9 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad.Extra-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map+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@@ -21,7 +22,7 @@ -- 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.-newtype Debouncer k = Debouncer (Var (Map k (Async ())))+newtype Debouncer k = Debouncer (Var (HashMap k (Async ())))  -- | Create a new empty debouncer. newDebouncer :: IO (Debouncer k)@@ -35,7 +36,7 @@ -- 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.-registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()+registerEvent :: (Eq k, Hashable k) => Debouncer k -> Seconds -> k -> IO () -> IO () registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do     whenJust (Map.lookup k m) cancel     a <- asyncWithUnmask $ \unmask -> unmask $ do

@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedLists      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+module Development.IDE.Core.FileExists+  ( fileExistsRules+  , modifyFileExists+  , getFileExists+  )+where++import           Control.Concurrent.Extra+import           Control.Exception+import           Control.Monad.Extra+import qualified Data.Aeson                    as A+import           Data.Binary+import qualified Data.ByteString               as BS+import           Data.Map.Strict                ( Map )+import qualified Data.Map.Strict               as Map+import           Data.Maybe+import qualified Data.Text                     as T+import           Development.IDE.Core.FileStore+import           Development.IDE.Core.Shake+import           Development.IDE.Types.Location+import           Development.Shake+import           Development.Shake.Classes+import           GHC.Generics+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Types+import           Language.Haskell.LSP.Types.Capabilities+import qualified System.Directory as Dir++-- | A map for tracking the file existence+type FileExistsMap = (Map NormalizedFilePath Bool)++-- | A wrapper around a mutable 'FileExistsMap'+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+modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()+modifyFileExistsAction f = do+  FileExistsMapVar var <- getIdeGlobalAction+  liftIO $ modifyVar_ var f++-- | Modify the global store of file exists+modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()+modifyFileExists state changes = do+  FileExistsMapVar var <- getIdeGlobalState state+  changesMap           <- evaluate $ Map.fromList changes++  -- Masked to ensure that the previous values are flushed together with the map update+  mask $ \_ -> do+    -- update the map+    modifyVar_ var $ evaluate . Map.union changesMap+    -- 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++-- | 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 :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()+fileExistsRules getLspId ClientCapabilities{_workspace}+  | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+  , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+  , Just True <- _dynamicRegistration+  = fileExistsRulesFast getLspId+  | otherwise = fileExistsRulesSlow++--   Requires an lsp client that provides WatchedFiles notifications.+fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()+fileExistsRulesFast getLspId vfs = do+  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])+  defineEarlyCutoff $ \GetFileExists file -> do+    fileExistsMap <- getFileExistsMapUntracked+    let mbFilesWatched = Map.lookup file fileExistsMap+    case mbFilesWatched of+      Just fv -> pure (summarizeExists fv, ([], Just fv))+      Nothing -> do+        exist                   <- liftIO $ getFileExistsVFS vfs file+        ShakeExtras { eventer } <- getShakeExtras++        -- add a listener for VFS Create/Delete file events,+        -- taking the FileExistsMap lock to prevent race conditions+        -- that would lead to multiple listeners for the same path+        modifyFileExistsAction $ \x -> do+          case Map.insertLookupWithKey (\_ x _ -> x) file exist x of+            (Nothing, x') -> do+            -- if the listener addition fails, we never recover. This is a bug.+              addListener eventer file+              return x'+            (Just _, _) ->+              -- if the key was already there, do nothing+              return x++        pure (summarizeExists exist, ([], Just exist))+ where+  addListener eventer fp = do+    reqId <- getLspId+    let+      req = RequestMessage "2.0" reqId ClientRegisterCapability regParams+      fpAsId       = T.pack $ fromNormalizedFilePath fp+      regParams    = RegistrationParams (List [registration])+      registration = Registration fpAsId+                                  WorkspaceDidChangeWatchedFiles+                                  (Just (A.toJSON regOptions))+      regOptions =+        DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }+      watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp+                                  , kind        = Just 5 -- Create and Delete events only+                                  }++    eventer $ ReqRegisterCapability req++summarizeExists :: Bool -> Maybe BS.ByteString+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty++fileExistsRulesSlow:: VFSHandle -> Rules ()+fileExistsRulesSlow vfs = do+  defineEarlyCutoff $ \GetFileExists file -> do+    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)++--------------------------------------------------------------------------------------------------+-- The message definitions below probably belong in haskell-lsp-types++data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions+    { watchers :: List FileSystemWatcher+    }++instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where+  toJSON DidChangeWatchedFilesRegistrationOptions {..} =+    A.object ["watchers" A..= watchers]++data FileSystemWatcher = FileSystemWatcher+    { -- | The glob pattern to watch.+      --   For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles+      globPattern :: String+        -- | The kind of event to subscribe to. Defaults to all.+        --   Defined as a bitmap of Create(1), Change(2), and Delete(4)+    , kind        :: Maybe Int+    }++instance A.ToJSON FileSystemWatcher where+  toJSON FileSystemWatcher {..} =+    A.object+      $  ["globPattern" A..= globPattern]+      ++ [ "kind" A..= x | Just x <- [kind] ]

@@ -4,32 +4,25 @@ {-# LANGUAGE TypeFamilies #-}  module Development.IDE.Core.FileStore(-    getFileExists, getFileContents,+    getFileContents,+    getVirtualFile,     setBufferModified,     setSomethingModified,     fileStoreRules,     VFSHandle,     makeVFSHandle,-    makeLSPVFSHandle,-    getSourceFingerprint+    makeLSPVFSHandle     ) where -import Foreign.Ptr-import Foreign.ForeignPtr-import Fingerprint-import           StringBuffer import Development.IDE.GHC.Orphans()-import Development.IDE.GHC.Util-+import           Development.IDE.Core.Shake import Control.Concurrent.Extra import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import           Control.Monad.Extra-import qualified System.Directory as Dir import           Development.Shake import           Development.Shake.Classes-import           Development.IDE.Core.Shake import           Control.Exception import           GHC.Generics import Data.Either.Extra@@ -41,7 +34,9 @@  #ifdef mingw32_HOST_OS import Data.Time+import qualified System.Directory as Dir #else+import Foreign.Ptr import Foreign.C.String import Foreign.C.Types import Foreign.Marshal (alloca)@@ -88,18 +83,7 @@   -- | 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 StringBuffer)---- | Does the file exist.-type instance RuleResult GetFileExists = Bool--type instance RuleResult FingerprintSource = Fingerprint--data GetFileExists = GetFileExists-    deriving (Eq, Show, Generic)-instance Hashable GetFileExists-instance NFData   GetFileExists-instance Binary   GetFileExists+type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)  data GetFileContents = GetFileContents     deriving (Eq, Show, Generic)@@ -107,31 +91,6 @@ instance NFData   GetFileContents instance Binary   GetFileContents -data FingerprintSource = FingerprintSource-    deriving (Eq, Show, Generic)-instance Hashable FingerprintSource-instance NFData   FingerprintSource-instance Binary   FingerprintSource--fingerprintSourceRule :: Rules ()-fingerprintSourceRule =-    define $ \FingerprintSource file -> do-      (_, mbContent) <- getFileContents file-      content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent-      fingerprint <- liftIO $ fpStringBuffer content-      pure ([], Just fingerprint)-    where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len--getFileExistsRule :: VFSHandle -> Rules ()-getFileExistsRule vfs =-    defineEarlyCutoff $ \GetFileExists file -> do-        alwaysRerun-        res <- liftIO $ handle (\(_ :: IOException) -> return False) $-            (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^-            Dir.doesFileExist (fromNormalizedFilePath file)-        return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))-- getModificationTimeRule :: VFSHandle -> Rules () getModificationTimeRule vfs =     defineEarlyCutoff $ \GetModificationTime file -> do@@ -154,6 +113,8 @@     -- 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 BS.ByteString     getModTime f = #ifdef mingw32_HOST_OS@@ -173,9 +134,6 @@ foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int #endif -getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint-getSourceFingerprint = use_ FingerprintSource- getFileContentsRule :: VFSHandle -> Rules () getFileContentsRule vfs =     define $ \GetFileContents file -> do@@ -183,7 +141,7 @@         time <- use_ GetModificationTime file         res <- liftIO $ ideTryIOException file $ do             mbVirtual <- getVirtualFile vfs $ filePathToUri' file-            pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual+            pure $ Rope.toText . _text <$> mbVirtual         case res of             Left err -> return ([err], Nothing)             Right contents -> return ([], Just (time, contents))@@ -195,24 +153,14 @@       <$> try act  -getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text) getFileContents = use_ GetFileContents -getFileExists :: NormalizedFilePath -> Action Bool-getFileExists =-    -- 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-    use_ GetFileExists-- fileStoreRules :: VFSHandle -> Rules () fileStoreRules vfs = do     addIdeGlobal vfs     getModificationTimeRule vfs     getFileContentsRule vfs-    getFileExistsRule vfs-    fingerprintSourceRule   -- | Notify the compiler service that a particular file has been modified.

@@ -1,19 +1,17 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 --{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} --- | A Shake implementation of the compiler service, built---   using the "Shaker" abstraction layer for in-memory use.---+-- | 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,     ) where -import           Control.Concurrent.Extra+import Control.Concurrent.Extra import Data.Binary import Data.Hashable import Control.DeepSeq@@ -21,26 +19,23 @@ import Data.Typeable import qualified Data.ByteString.UTF8 as BS import Control.Exception-import Development.IDE.Types.Location-import Development.IDE.Types.Logger-import           Data.Set                                 (Set)-import qualified Data.Set                                 as Set+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Text as T import Data.Tuple.Extra import Data.Functor-import           Development.Shake--import           Development.IDE.Core.Shake+import Development.Shake +import Development.IDE.Types.Location+import Development.IDE.Types.Logger+import Development.IDE.Core.Shake   newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath)) instance IsIdeGlobal OfInterestVar - type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath - data GetFilesOfInterest = GetFilesOfInterest     deriving (Eq, Show, Typeable, Generic) instance Hashable GetFilesOfInterest@@ -48,6 +43,7 @@ instance Binary   GetFilesOfInterest  +-- | The rule that initialises the files of interest state. ofInterestRules :: Rules () ofInterestRules = do     addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)@@ -57,6 +53,7 @@         pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))  +-- | Get the files that are open in the IDE. getFilesOfInterest :: Action (Set NormalizedFilePath) getFilesOfInterest = useNoFile_ GetFilesOfInterest @@ -65,7 +62,8 @@ ------------------------------------------------------------ -- Exposed API --- | Set the files-of-interest which will be built and kept-up-to-date.+-- | Set the files-of-interest - not usually necessary or advisable.+--   The LSP client will keep this information up to date. setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO () setFilesOfInterest state files = modifyFilesOfInterest state (const files) @@ -74,6 +72,8 @@     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 -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO () modifyFilesOfInterest state f = do     OfInterestVar var <- getIdeGlobalState state

@@ -167,10 +167,18 @@     escape []        = []  +modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags+modifyOptP op = onSettings (onOptP op)+  where+    onSettings f x = x{settings = f $ settings x}+    onOptP f x = x{sOpt_P = f $ sOpt_P x}+ -- | 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 $ modifyOptP ("-D__GHCIDE__":) dflags+     case contents of         Nothing -> do             -- Happy case, file is not modified, so run CPP on it in-place

@@ -27,7 +27,6 @@ import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails) import Development.IDE.GHC.Compat -import           Development.IDE.Core.CompletionsTypes import           Development.IDE.Spans.Type  @@ -63,7 +62,7 @@ type instance RuleResult TypeCheck = TcModuleResult  -- | Information about what spans occur where, requires TypeCheck-type instance RuleResult GetSpanInfo = [SpanInfo]+type instance RuleResult GetSpanInfo = SpansInfo  -- | Convert to Core, requires TypeCheck* type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)@@ -86,10 +85,7 @@ -- | Read the given HIE file. type instance RuleResult GetHieFile = HieFile --- | Produce completions info for a file-type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult) - data GetParsedModule = GetParsedModule     deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule@@ -157,9 +153,3 @@ instance Hashable GetHieFile instance NFData   GetHieFile instance Binary   GetHieFile--data ProduceCompletions = ProduceCompletions-    deriving (Eq, Show, Typeable, Generic)-instance Hashable ProduceCompletions-instance NFData   ProduceCompletions-instance Binary   ProduceCompletions

@@ -21,7 +21,6 @@     getDefinition,     getDependencies,     getParsedModule,-    fileFromParsedModule,     generateCore,     ) where @@ -32,12 +31,12 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Development.IDE.Core.Compile-import Development.IDE.Core.Completions import Development.IDE.Types.Options import Development.IDE.Spans.Calculate import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports-import           Development.IDE.Core.FileStore+import           Development.IDE.Core.FileExists+import           Development.IDE.Core.FileStore        (getFileContents) import           Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.GHC.Util@@ -53,6 +52,7 @@ import           Development.IDE.GHC.Error import           Development.Shake                        hiding (Diagnostic) import Development.IDE.Core.RuleTypes+import Development.IDE.Spans.Type  import           GHC hiding (parseModule, typecheckModule) import qualified GHC.LanguageExtensions as LangExt@@ -104,9 +104,7 @@ getAtPoint file pos = fmap join $ runMaybeT $ do   opts <- lift getIdeOptions   spans <- useE GetSpanInfo file-  files <- transitiveModuleDeps <$> useE GetDependencies file-  tms   <- usesE TypeCheck (file : files)-  return $ AtPoint.atPoint opts (map tmrModule tms) spans pos+  return $ AtPoint.atPoint opts spans pos  -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)@@ -115,7 +113,7 @@     spans <- useE GetSpanInfo file     pkgState <- hscEnv <$> useE GhcSession file     let getHieFile x = useNoFile (GetHieFile x)-    lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos+    lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos  -- | Parse the contents of a daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)@@ -140,9 +138,14 @@         (_, contents) <- getFileContents file         packageState <- hscEnv <$> use_ GhcSession file         opt <- getIdeOptions-        r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents-        mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)-        pure (fingerprintToBS <$> mbFingerprint, r)+        (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)+        case res of+            Nothing -> pure (Nothing, (diag, Nothing))+            Just (contents, modu) -> do+                mbFingerprint <- if isNothing $ optShakeFiles opt+                    then pure Nothing+                    else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents+                pure (mbFingerprint, (diag, Just modu))  getLocatedImportsRule :: Rules () getLocatedImportsRule =@@ -262,9 +265,11 @@ getSpanInfoRule =     define $ \GetSpanInfo file -> do         tc <- use_ TypeCheck file+        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file+        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)         (fileImports, _) <- use_ GetLocatedImports file         packageState <- hscEnv <$> use_ GhcSession file-        x <- liftIO $ getSrcSpanInfos packageState fileImports tc+        x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms         return ([], Just x)  -- Typechecks a module.@@ -305,20 +310,6 @@ generateCoreRule =     define $ \GenerateCore -> generateCore -produceCompletions :: Rules ()-produceCompletions =-    define $ \ProduceCompletions file -> do-        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file-        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)-        tm <- fmap fst <$> useWithStale TypeCheck file-        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file-        case (tm, packageState) of-            (Just tm', Just packageState') -> do-                cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')-                                                    (tmrModule tm') (map tmrModule tms)-                return ([], Just (cdata, tm'))-            _ -> return ([], Nothing)- generateByteCodeRule :: Rules () generateByteCodeRule =     define $ \GenerateByteCode file -> do@@ -376,9 +367,3 @@     generateByteCodeRule     loadGhcSession     getHieFileRule-    produceCompletions----------------------------------------------------------------fileFromParsedModule :: ParsedModule -> NormalizedFilePath-fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary

@@ -23,13 +23,15 @@ import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) import Control.Monad-import           Development.IDE.Core.FileStore+import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules)+import           Development.IDE.Core.FileExists (fileExistsRules) import           Development.IDE.Core.OfInterest import Development.IDE.Types.Logger import           Development.Shake import Data.Either.Extra 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 @@ -42,14 +44,15 @@ -- Exposed API  -- | Initialise the Compiler Service.-initialise :: Rules ()+initialise :: LSP.ClientCapabilities+           -> Rules ()            -> IO LSP.LspId            -> (LSP.FromServerMessage -> IO ())            -> Logger            -> IdeOptions            -> VFSHandle            -> IO IdeState-initialise mainRule getLspId toDiags logger options vfs =+initialise caps mainRule getLspId toDiags logger options vfs =     shakeOpen         getLspId         toDiags@@ -63,6 +66,7 @@             addIdeGlobal $ GlobalIdeOptions options             fileStoreRules vfs             ofInterestRules+            fileExistsRules getLspId caps vfs             mainRule  writeProfile :: IdeState -> FilePath -> IO ()

@@ -20,13 +20,14 @@ --   between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake(     IdeState,+    ShakeExtras(..), getShakeExtras,     IdeRule, IdeResult, GetModificationTime(..),     shakeOpen, shakeShut,     shakeRun,     shakeProfile,     use, useWithStale, useNoFile, uses, usesWithStale,     use_, useNoFile_, uses_,-    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,+    define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,     getDiagnostics, unsafeClearDiagnostics,     getHiddenDiagnostics,     IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,@@ -38,7 +39,8 @@     FileVersion(..),     Priority(..),     updatePositionMapping,-    OnDiskRule(..)+    deleteValue,+    OnDiskRule(..),     ) where  import           Development.Shake hiding (ShakeValue, doesFileExist)@@ -49,7 +51,6 @@ import qualified Data.Map.Strict as Map import qualified Data.Map.Merge.Strict as Map import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Internal as BS import           Data.Dynamic import           Data.Maybe import Data.Map.Strict (Map)@@ -62,14 +63,12 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.PositionMapping import Development.IDE.Types.Logger hiding (Priority)-import Foreign.Ptr-import Foreign.Storable-import GHC.Fingerprint import Language.Haskell.LSP.Diagnostics import qualified Data.SortedList as SL import           Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options+import           Control.Concurrent.Async import           Control.Concurrent.Extra import           Control.Exception import           Control.DeepSeq@@ -102,6 +101,8 @@     ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion 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+    ,inProgress :: Var (Map NormalizedFilePath Int)+    -- ^ How many rules are running for each file     }  getShakeExtras :: Action ShakeExtras@@ -257,6 +258,16 @@     -- 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@@ -289,6 +300,7 @@           -> Rules ()           -> IO IdeState shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do+    inProgress <- newVar Map.empty     shakeExtras <- do         globals <- newVar HMap.empty         state <- newVar HMap.empty@@ -302,15 +314,20 @@         shakeOpenDatabase             opts                 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts-                , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())+                -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever+                -- we call into Shake, so abuse it for that purpose+                , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()                 }             rules     shakeAbort <- newMVar $ return ()     shakeDb <- shakeDb     return IdeState{..} -lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()-lspShakeProgress getLspId sendMsg prog = do+lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO ()+lspShakeProgress getLspId sendMsg inProgress = 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)+    sleep 0.1     lspId <- getLspId     u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique     sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest@@ -338,9 +355,9 @@         sample = 0.1         loop id prev = do             sleep sample-            p <- prog-            let done = countSkipped p + countBuilt p-            let todo = done + countUnknown p + countTodo p+            current <- readVar inProgress+            let done = length $ filter (== 0) $ Map.elems current+            let todo = Map.size current             let next = Just $ T.pack $ show done <> "/" <> show todo             when (next /= prev) $                 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification@@ -366,11 +383,11 @@  -- | 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' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c withMVar' var unmasked masked = mask $ \restore -> do     a <- takeMVar var-    b <- restore (unmasked a) `onException` putMVar var a-    (a', c) <- masked b+    restore (unmasked a) `onException` putMVar var a+    (a', c) <- masked     putMVar var a'     pure c @@ -382,29 +399,33 @@         (\stop -> do               (stopTime,_) <- duration stop               logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"-              bar <- newBarrier-              start <- offsetTime-              pure (start, bar))+        )         -- It is crucial to be masked here, otherwise we can get killed         -- between spawning the new thread and updating shakeAbort.         -- See https://github.com/digital-asset/ghcide/issues/79-        (\(start, bar) -> do-              thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do-                  runTime <- start-                  let res' = case res of-                          Left e -> "exception: " <> displayException e-                          Right _ -> "completed"-                      profile = case res of-                          Right (_, Just fp) -> -                              let link = case filePathToUri' $ toNormalizedFilePath fp of-                                            NormalizedUri x -> x-                              in ", profile saved at " <> T.unpack link-                          _ -> ""-                  logDebug logger $ T.pack $-                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"-                  signalBarrier bar (fst <$> res)-              -- important: we send an async exception to the thread, then wait for it to die, before continuing-              pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))+        (do+              start <- offsetTime+              aThread <- asyncWithUnmask $ \restore -> do+                   res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)+                   runTime <- start+                   let res' = case res of+                            Left e -> "exception: " <> displayException e+                            Right _ -> "completed"+                       profile = case res of+                            Right (_, Just fp) ->+                                let link = case filePathToUri' $ toNormalizedFilePath fp of+                                                NormalizedUri x -> x+                                in ", profile saved at " <> T.unpack link+                            _ -> ""+                   let logMsg = logDebug logger $ T.pack $+                        "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"+                   return (fst <$> res, logMsg)+              let wrapUp (res, _) = do+                    either (throwIO @SomeException) return res+              _ <- async $ do+                  (_, logMsg) <- wait aThread+                  logMsg+              pure (cancel aThread, wrapUp =<< wait aThread))  getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do@@ -512,50 +533,58 @@     values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)     mapM (uncurry lastValue) (zip files values) ++withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b+withProgress var file = actionBracket (f succ) (const $ f pred) . const+    where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file++ 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 -> do-    extras@ShakeExtras{state} <- getShakeExtras-    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 (decodeShakeValue old)-                _ -> 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 $ join . fmap 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 bs+    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 withProgress 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 (decodeShakeValue old)+                    _ -> 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 $ join . fmap 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 bs   -- | Rule type, input file@@ -622,12 +651,6 @@                           | mbHash == Just old = ChangedRecomputeSame                           | otherwise = ChangedRecomputeDiff                     pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)--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  needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () needOnDisk k file = do

@@ -28,7 +28,9 @@ import DynFlags import Panic import FileCleanup-#if MIN_GHC_API_VERSION(8,8,0)+#if MIN_GHC_API_VERSION(8,8,2)+import LlvmCodeGen (llvmVersionList)+#elif MIN_GHC_API_VERSION(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif @@ -114,8 +116,6 @@                     ++ map SysTools.Option sse_defs                     ++ map SysTools.Option avx_defs                     ++ mb_macro_include-        -- Define a special macro "__GHCIDE__"-                    ++ [ SysTools.Option "-D__GHCIDE__"]         -- 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@@ -139,7 +139,11 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do     llvmVer <- figureLlvmVersion dflags     return $ case llvmVer of-#if MIN_GHC_API_VERSION(8,8,0)+#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

@@ -16,7 +16,6 @@     includePathsGlobal,     includePathsQuote,     addIncludePathsQuote,-    ghcEnumerateExtensions,     pattern DerivD,     pattern ForD,     pattern InstD,@@ -31,12 +30,7 @@ import StringBuffer import DynFlags import FieldLabel-import GHC.LanguageExtensions.Type -#if MIN_GHC_API_VERSION(8,8,0)-import Data.List.Extra (enumerate)-#endif- import qualified GHC import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD) @@ -86,15 +80,6 @@     where f i = i{includePathsQuote = path : includePathsQuote i} #else addIncludePathsQuote path x = x{includePaths = path : includePaths x}-#endif--ghcEnumerateExtensions :: [Extension]-#if MIN_GHC_API_VERSION(8,8,0)-ghcEnumerateExtensions = enumerate-#elif MIN_GHC_API_VERSION(8,6,0)-ghcEnumerateExtensions = [Cpp .. StarIsType]-#else-ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving] #endif  pattern DerivD :: DerivDecl p -> HsDecl p

@@ -16,6 +16,8 @@   , srcSpanToFilename   , zeroSpan   , realSpan+  , isInsideSrcSpan+  , noSpan    -- * utilities working with severities   , toDSeverity@@ -79,6 +81,10 @@ srcSpanToLocation src =   -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code   Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)++isInsideSrcSpan :: Position -> SrcSpan -> Bool+p `isInsideSrcSpan` r = sp <= p && p <= ep+  where Range sp ep = srcSpanToRange r  -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing).

@@ -5,23 +5,24 @@ {-# LANGUAGE CPP #-} #include "ghc-api-version.h" --- | GHC utility functions. Importantly, code using our GHC should never:------ * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.------ * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.+-- | General utility functions, mostly focused around GHC operations. module Development.IDE.GHC.Util(-    lookupPackageConfig,+    -- * HcsEnv and environment+    HscEnvEq, hscEnv, newHscEnvEq,     modifyDynFlags,     fakeDynFlags,-    prettyPrint,     runGhcEnv,-    textToStringBuffer,+    -- * GHC wrappers+    prettyPrint,+    lookupPackageConfig,     moduleImportPath,-    HscEnvEq, hscEnv, newHscEnvEq,+    cgGutsToCoreModule,+    fingerprintToBS,+    fingerprintFromStringBuffer,+    -- * General utilities+    textToStringBuffer,     readFileUtf8,     hDuplicateTo',-    cgGutsToCoreModule     ) where  import Config@@ -29,15 +30,17 @@ import Data.List.Extra import Data.Maybe import Data.Typeable-#if MIN_GHC_API_VERSION(8,6,0)+import qualified Data.ByteString.Internal as BS import Fingerprint-#endif import GHC import GhcMonad import GhcPlugins hiding (Unique) import Data.IORef import Control.Exception 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@@ -60,6 +63,8 @@ ---------------------------------------------------------------------- -- 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@@ -68,6 +73,7 @@   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@@ -78,14 +84,18 @@             getPackageConfigMap $ hsc_dflags env  --- would be nice to do this more efficiently...+-- | 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  +-- | Pretty print a GHC value using 'fakeDynFlags'. prettyPrint :: Outputable a => a -> String prettyPrint = showSDoc fakeDynFlags . ppr +-- | 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 a runGhcEnv env act = do     filesToClean <- newIORef emptyFilesToClean@@ -96,8 +106,8 @@         cleanTempFiles dflags         cleanTempDirs dflags --- Fake DynFlags which are mostly undefined, but define enough to do a--- little bit.+-- | A 'DynFlags' value where most things are undefined. It's sufficient to call pretty printing,+--   but not much else. fakeDynFlags :: DynFlags fakeDynFlags = defaultDynFlags settings mempty     where@@ -120,6 +130,9 @@           , pc_WORD_SIZE=8           } +-- | 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.ParsedModule -> 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.@@ -137,12 +150,15 @@         fromNormalizedFilePath $ toNormalizedFilePath $         moduleNameSlashes $ GHC.moduleName mod' --- | An HscEnv with equality.+-- | An 'HscEnv' with equality. Two values are considered equal+--   if they are created with the same call to 'newHscEnvEq'. data HscEnvEq = HscEnvEq Unique HscEnv +-- | Unwrap an 'HsEnvEq'. hscEnv :: HscEnvEq -> HscEnv hscEnv (HscEnvEq _ x) = x +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEq :: HscEnv -> IO HscEnvEq newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e @@ -155,9 +171,11 @@ instance NFData HscEnvEq where   rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` () +-- | 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)@@ -165,8 +183,22 @@     (cg_binds guts)     safeMode --- This is a slightly modified version of hDuplicateTo in GHC.--- See the inline comment for more details.+-- | 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

@@ -1,467 +0,0 @@--- 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.LSP.CodeAction-    ( setHandlersCodeAction-    , setHandlersCodeLens-    ) where--import           Language.Haskell.LSP.Types-import Control.Monad (join)-import Development.IDE.GHC.Compat-import Development.IDE.Core.Rules-import Development.IDE.Core.RuleTypes-import Development.IDE.Core.Shake-import Development.IDE.GHC.Error-import Development.IDE.LSP.Server-import Development.IDE.Types.Location-import qualified Data.HashMap.Strict as Map-import qualified Data.HashSet as Set-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.VFS-import Language.Haskell.LSP.Messages-import qualified Data.Rope.UTF16 as Rope-import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))-import Control.Monad.Trans.Maybe-import Data.Char-import Data.Maybe-import Data.List.Extra-import qualified Data.Text as T-import Text.Regex.TDFA ((=~), (=~~))-import Text.Regex.TDFA.Text()-import Outputable (ppr, showSDocUnsafe)---- | Generate code actions.-codeAction-    :: LSP.LspFuncs ()-    -> IdeState-    -> CodeActionParams-    -> IO (List CAResult)-codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do-    -- disable logging as its quite verbose-    -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents-    parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri-    pure $ List-        [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing-        | x <- xs, (title, tedit) <- suggestAction ( join parsedModule ) text x-        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing-        ]---- | Generate code lenses.-codeLens-    :: LSP.LspFuncs ()-    -> IdeState-    -> CodeLensParams-    -> IO (List CodeLens)-codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do-    case uriToFilePath' uri of-      Just (toNormalizedFilePath -> filePath) -> do-        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath-        diag <- getDiagnostics ideState-        hDiag <- getHiddenDiagnostics ideState-        pure $ List-          [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing-          | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag-          , dFile == filePath-          , (title, tedit) <- suggestSignature False dDiag-          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing-          ]-      Nothing -> pure $ List []---- | Execute the "typesignature.add" command.-executeAddSignatureCommand-    :: LSP.LspFuncs ()-    -> IdeState-    -> ExecuteCommandParams-    -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))-executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}-    | _command == "typesignature.add"-    , Just (List [edit]) <- _arguments-    , Success wedit <- fromJSON edit -    = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))-    | otherwise-    = return (Null, Nothing)--suggestAction  :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAction parsedModule text diag = concat-    [ suggestAddExtension diag-    , suggestExtendImport text diag-    , suggestFillHole diag-    , suggestFillTypeWildcard diag-    , suggestFixConstructorImport text diag-    , suggestModuleTypo diag-    , suggestReplaceIdentifier text diag-    , suggestSignature True diag-    ] ++ concat-    [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]]---suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}---     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant-    | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"-    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports-    , Just c <- contents-    , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)-    , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat 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 = []--suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestReplaceIdentifier contents Diagnostic{_range=_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 = []--suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]-suggestFillTypeWildcard Diagnostic{_range=_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 = []--suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]-suggestAddExtension Diagnostic{_range=_range@Range{..},..}--- File.hs:22:8: error:---     Illegal lambda-case (use -XLambdaCase)--- File.hs:22:6: error:---     Illegal view pattern:  x -> foo---     Use ViewPatterns to enable view patterns--- File.hs:26:8: error:---     Illegal `..' in record pattern---     Use RecordWildCards to permit this--- File.hs:53:28: error:---     Illegal tuple section: use TupleSections--- File.hs:238:29: error:---     * Can't make a derived instance of `Data FSATrace':---         You need DeriveDataTypeable to derive an instance for this class---     * In the data declaration for `FSATrace'--- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:---     * Illegal equational constraint a ~ ()---       (Use GADTs or TypeFamilies to permit this)---     * In the context: a ~ ()---       While checking an instance declaration---       In the instance declaration for `Unit (m a)'-    | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message-        = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]-    | otherwise = []--suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]-suggestModuleTypo Diagnostic{_range=_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@Range{..},..}---  ...Development/IDE/LSP/CodeAction.hs:103:9: warning:---   * Found hole: _ :: Int -> String---   * In the expression: _---     In the expression: _ a---     In an equation for ‘foo’: foo a = _ a---   * Relevant bindings include---       a :: Int---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)---       foo :: Int -> String---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)---     Valid hole fits include---       foo :: Int -> String---         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)---       show :: forall a. Show a => a -> String---         with show @Int---         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37---          (and originally defined in ‘GHC.Show’))---       mempty :: forall a. Monoid a => a---         with mempty @(Int -> String)---         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37---          (and originally defined in ‘GHC.Base’)) (lsp-ui)--    | topOfHoleFitsMarker `T.isInfixOf` _message = let-      findSuggestedHoleFits :: T.Text -> [T.Text]-      findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines-      proposeHoleFit name = ("replace hole `" <> holeName <>  "` with " <> name, [TextEdit _range name])-      holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message-      dropPreceding       = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))-      selectLinesWithFits = filter ("::" `T.isInfixOf`)-      extractFitNames     = map (T.strip . head . T.splitOn " :: ")-      in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message--    | otherwise = []--suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestExtendImport contents Diagnostic{_range=_range,..}-    | Just [binding, mod, srcspan] <--      matchRegex _message-      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"-    , Just c <- contents-    = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of-            [s] -> let x = srcSpanToRange s-                   in x{_end = (_end x){_character = succ (_character (_end x))}}-            _ -> error "bug in srcspan parser"-          importLine = textInRange range c-        in [("Add " <> binding <> " to the import list of " <> mod-        , [TextEdit range (addBindingToImportList binding importLine)])]-    | otherwise = []--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] <--    matchRegex _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{..},..}-    | "Top-level binding with no type signature" `T.isInfixOf` _message = let-      filterNewlines = T.concat  . T.lines-      unifySpaces    = T.unwords . T.words-      signature      = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message-      startOfLine    = Position (_line _start) 0-      beforeLine     = Range startOfLine startOfLine-      title          = if isQuickFix then "add signature: " <> signature else signature-      action         = TextEdit beforeLine $ signature <> "\n"-      in [(title, [action])]-suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}-    | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let-      filterNewlines = T.concat  . T.lines-      unifySpaces    = T.unwords . T.words-      signature      = removeInitialForAll-                     $ T.takeWhile (\x -> x/='*' && x/='•')-                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message-      startOfLine    = Position (_line _start) (_character _start)-      beforeLine     = Range startOfLine startOfLine-      title          = if isQuickFix then "add signature: " <> signature else signature-      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "-      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-suggestSignature _ _ = []--topOfHoleFitsMarker :: T.Text-topOfHoleFitsMarker =-#if MIN_GHC_API_VERSION(8,6,0)-  "Valid hole fits include"-#else-  "Valid substitutions include"-#endif--mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit-mkRenameEdit contents range name =-    if fromMaybe False maybeIsInfixFunction-      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---- | All the GHC extensions-ghcExtensions :: Set.HashSet T.Text-ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions--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 (map 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 x@IEThingAll{}) | 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 :: T.Text -> T.Text -> T.Text-addBindingToImportList binding importLine = case T.breakOn "(" importLine of-    (pre, T.uncons -> Just (_, rest)) ->-      case T.uncons (T.dropWhile isSpace rest) of-        Just (')', _) -> T.concat [pre, "(", binding, rest]-        _             -> T.concat [pre, "(", binding, ", ", rest]-    _ ->-      error-        $  "importLine does not have the expected structure: "-        <> T.unpack importLine---- | Returns Just (the submatches) for the first capture, or Nothing.-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]-matchRegex message regex = case T.unwords (T.words message) =~~ regex of-    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings-    Nothing -> Nothing--setHandlersCodeAction :: PartialHandlers-setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.codeActionHandler = withResponse RspCodeAction codeAction-    }--setHandlersCodeLens :: PartialHandlers-setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.codeLensHandler = withResponse RspCodeLens codeLens,-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand-    }------------------------------------------------------------------------------------type PositionIndexedString = [(Position, Char)]--indexedByPosition :: String -> PositionIndexedString-indexedByPosition = unfoldr f . (Position 0 0,) 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))---- | Returns a tuple (before, contents, after)-unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)-unconsRange Range {..} indexedString = (before, mid, after)-  where-    (before, rest) = span ((/= _start) . fst) indexedString-    (mid, after) = span ((/= _end) . fst) rest--stripRange :: Range -> PositionIndexedString -> PositionIndexedString-stripRange r s = case unconsRange r s of-  (b, _, a) -> b ++ a--extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]-extendAllToIncludeCommaIfPossible _             [] =  []-extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr-  where-    r' = case extendToIncludeCommaIfPossible indexedString r of-          [] -> r-          r' : _ -> r'-    indexedString' = stripRange r' indexedString---- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas-extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]-extendToIncludeCommaIfPossible indexedString range =-    -- a, |b|, c ===> a|, b|, c-    [ range{_start = start'}-    | (start', ',') : _ <- [before']-    ]-    ++-    -- a, |b|, c ===> a, |b, |c-    [ range{_end = end'}-    |  (_, ',') : rest <- [after']-    , let (end', _) : _ = dropWhile (isSpace . snd) rest-    ]-  where-    (before, _, after) = unconsRange range indexedString-    after' = dropWhile (isSpace . snd) after-    before' = dropWhile (isSpace . snd) (reverse before)

@@ -1,51 +0,0 @@-module Development.IDE.LSP.Completions (-  setHandlersCompletion-) 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 Language.Haskell.LSP.Types.Capabilities--import Development.IDE.Core.Service-import Development.IDE.Core.Completions-import Development.IDE.Types.Location-import Development.IDE.Core.PositionMapping-import Development.IDE.Core.RuleTypes-import Development.IDE.Core.Shake-import Development.IDE.LSP.Server---- | Generate code actions.-getCompletionsLSP-    :: LSP.LspFuncs ()-    -> IdeState-    -> CompletionParams-    -> IO CompletionResponseResult-getCompletionsLSP lsp ide-  CompletionParams{_textDocument=TextDocumentIdentifier uri-                  ,_position=position-                  ,_context=completionContext} = do-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri-    case (contents, uriToFilePath' uri) of-      (Just cnts, Just path) -> do-        let npath = toNormalizedFilePath path-        (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)-        case compls of-          Just ((cci', tm'), mapping) -> do-            let position' = fromCurrentPosition mapping position-            pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'-            case (pfix, completionContext) of-              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})-                -> return (Completions $ List [])-              (Just pfix', _) -> do-                let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing-                Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)-              _ -> return (Completions $ List [])-          _ -> return (Completions $ List [])-      _ -> return (Completions $ List [])--setHandlersCompletion :: PartialHandlers-setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP-    }

@@ -20,8 +20,8 @@  import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams-hover          :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)+hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc hover          = request "Hover"      getAtPoint     Nothing      foundHover @@ -43,12 +43,12 @@   -> (a -> b)   -> IdeState   -> TextDocumentPositionParams-  -> IO b+  -> 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 $ maybe notFound found mbResult+    pure $ Right $ maybe notFound found mbResult  logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do

@@ -29,8 +29,6 @@ import Control.Monad.Extra  import Development.IDE.LSP.HoverDefinition-import Development.IDE.LSP.CodeAction-import Development.IDE.LSP.Completions import Development.IDE.LSP.Notifications import Development.IDE.LSP.Outline import Development.IDE.Core.Service@@ -98,8 +96,6 @@     let PartialHandlers parts =             setHandlersIgnore <> -- least important             setHandlersDefinition <> setHandlersHover <>-            setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override-            setHandlersCompletion <>             setHandlersOutline <>             userHandlers <>             setHandlersNotifications <> -- absolutely critical, join them with user notifications@@ -138,8 +134,10 @@                                 "Message: " ++ show x ++ "\n" ++                                 "Exception: " ++ show e                     Response x@RequestMessage{_id, _params} wrap act ->-                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ -                            \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing+                        checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $+                            \case+                              Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)+                              Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing                     ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->                         checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $                             \(res, newReq) -> do@@ -195,7 +193,7 @@ -- | 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-    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)+    = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> 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.

@@ -2,26 +2,30 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes            #-}  module Development.IDE.LSP.Notifications     ( setHandlersNotifications     ) where -import           Language.Haskell.LSP.Types import           Development.IDE.LSP.Server-import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.Types as LSP+import qualified Language.Haskell.LSP.Core        as LSP+import           Language.Haskell.LSP.Types+import qualified Language.Haskell.LSP.Types       as LSP -import Development.IDE.Types.Logger-import Development.IDE.Core.Service-import Development.IDE.Types.Location+import           Development.IDE.Core.Service+import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger -import Control.Monad.Extra-import qualified Data.Set                                  as S+import           Control.Monad.Extra+import           Data.Foldable                    as F+import           Data.Maybe+import qualified Data.Set                         as S+import qualified Data.Text                        as Text -import Development.IDE.Core.FileStore-import Development.IDE.Core.OfInterest+import           Development.IDE.Core.FileStore   (setSomethingModified)+import           Development.IDE.Core.FileExists  (modifyFileExists)+import           Development.IDE.Core.OfInterest   whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()@@ -52,4 +56,17 @@             whenUriFile _uri $ \file -> do                 modifyFilesOfInterest ide (S.delete file)                 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri+    ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $+        \_ ide (DidChangeWatchedFilesParams fileEvents) -> do+            let events =+                    mapMaybe+                        (\(FileEvent uri ev) ->+                            (, ev /= FcDeleted) . toNormalizedFilePath+                            <$> LSP.uriToFilePath uri+                        )+                        ( F.toList fileEvents )+            let msg = Text.pack $ show events+            logInfo (ideLogger ide) $ "Files created or deleted: " <> msg+            modifyFileExists ide events+            setSomethingModified ide     }

@@ -34,12 +34,12 @@   }  moduleOutline-  :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult+  :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult) moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }   = case uriToFilePath uri of     Just (toNormalizedFilePath -> fp) -> do       mb_decls <- runAction ideState $ use GetParsedModule fp-      pure $ case mb_decls of+      pure $ Right $ case mb_decls of         Nothing -> DSDocumentSymbols (List [])         Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })           -> let@@ -61,7 +61,7 @@                DSDocumentSymbols (List allSymbols)  -    Nothing -> pure $ DSDocumentSymbols (List [])+    Nothing -> pure $ Right $ DSDocumentSymbols (List [])  documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

@@ -16,17 +16,16 @@ import qualified Language.Haskell.LSP.Messages as LSP import Development.IDE.Core.Service - data WithMessage = WithMessage     {withResponse :: forall m req resp . (Show m, Show req) =>         (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response-        (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work+        (LSP.LspFuncs () -> 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 () -> IdeState -> req -> IO ()) -> -- actual work         Maybe (LSP.Handler (NotificationMessage m req))-    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody. +    ,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

@@ -0,0 +1,34 @@++module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where++import Data.Default+import Development.Shake+import Development.IDE.LSP.Server++import           Language.Haskell.LSP.Types+import Development.IDE.Core.Rules+import qualified Language.Haskell.LSP.Core as LSP+import Language.Haskell.LSP.Messages+++data Plugin = Plugin+    {pluginRules :: Rules ()+    ,pluginHandler :: PartialHandlers+    }++instance Default Plugin where+    def = Plugin mempty def++instance Semigroup Plugin where+    Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)++instance Monoid Plugin where+    mempty = def+++codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin+codeActionPlugin f = Plugin mempty $ 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

@@ -0,0 +1,505 @@+-- 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) where++import           Language.Haskell.LSP.Types+import Control.Monad (join)+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.Types.Location+import Development.IDE.Types.Options+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 qualified Data.Rope.UTF16 as Rope+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))+import Control.Monad.Trans.Maybe+import Data.Char+import Data.Maybe+import Data.List.Extra+import qualified Data.Text as T+import Data.Tuple.Extra ((&&&))+import Text.Regex.TDFA ((=~), (=~~))+import Text.Regex.TDFA.Text()+import Outputable (ppr, showSDocUnsafe)+import DynFlags (xFlags, FlagSpec(..))+import GHC.LanguageExtensions.Type (Extension)++plugin :: Plugin+plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens++-- | Generate code actions.+codeAction+    :: LSP.LspFuncs ()+    -> IdeState+    -> TextDocumentIdentifier+    -> Range+    -> CodeActionContext+    -> IO (Either ResponseError [CAResult])+codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do+    -- disable logging as its quite verbose+    -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg+    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents+    (ideOptions, parsedModule) <- runAction state $+      (,) <$> getIdeOptions+          <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri+    pure $ Right+        [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing+        | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x+        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing+        ]++-- | Generate code lenses.+codeLens+    :: LSP.LspFuncs ()+    -> IdeState+    -> CodeLensParams+    -> IO (Either ResponseError (List CodeLens))+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do+    fmap (Right . List) $ case uriToFilePath' uri of+      Just (toNormalizedFilePath -> filePath) -> do+        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath+        diag <- getDiagnostics ideState+        hDiag <- getHiddenDiagnostics ideState+        pure+          [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing+          | (dFile, _, dDiag@Diagnostic{_range=_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.+executeAddSignatureCommand+    :: LSP.LspFuncs ()+    -> IdeState+    -> ExecuteCommandParams+    -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}+    | _command == "typesignature.add"+    , Just (List [edit]) <- _arguments+    , Success wedit <- fromJSON edit+    = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))+    | otherwise+    = return (Null, Nothing)++suggestAction  :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestAction ideOptions parsedModule text diag = concat+    [ suggestAddExtension diag+    , suggestExtendImport text diag+    , suggestFillHole diag+    , suggestFillTypeWildcard diag+    , suggestFixConstructorImport text diag+    , suggestModuleTypo diag+    , suggestReplaceIdentifier text diag+    , suggestSignature True diag+    ] ++ concat+    [  suggestNewDefinition ideOptions pm text diag+    ++ suggestRemoveRedundantImport pm text diag+    | Just pm <- [parsedModule]]+++suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}+--     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant+    | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"+    , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports+    , Just c <- contents+    , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)+    , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat 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 = []++suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestReplaceIdentifier contents Diagnostic{_range=_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] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"+    = newDefinitionAction ideOptions parsedModule _range name typ+    | Just [name, typ] <- matchRegex 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 : _ <-+      [ srcSpanToRange l+      | (L l _) <- 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@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 = []++suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]+suggestAddExtension Diagnostic{_range=_range@Range{..},..}+-- File.hs:22:8: error:+--     Illegal lambda-case (use -XLambdaCase)+-- File.hs:22:6: error:+--     Illegal view pattern:  x -> foo+--     Use ViewPatterns to enable view patterns+-- File.hs:26:8: error:+--     Illegal `..' in record pattern+--     Use RecordWildCards to permit this+-- File.hs:53:28: error:+--     Illegal tuple section: use TupleSections+-- File.hs:238:29: error:+--     * Can't make a derived instance of `Data FSATrace':+--         You need DeriveDataTypeable to derive an instance for this class+--     * In the data declaration for `FSATrace'+-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:+--     * Illegal equational constraint a ~ ()+--       (Use GADTs or TypeFamilies to permit this)+--     * In the context: a ~ ()+--       While checking an instance declaration+--       In the instance declaration for `Unit (m a)'+    | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message+        = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]+    | otherwise = []++-- | All the GHC extensions+ghcExtensions :: Map.HashMap T.Text Extension+ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags++suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]+suggestModuleTypo Diagnostic{_range=_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@Range{..},..}+--  ...Development/IDE/LSP/CodeAction.hs:103:9: warning:+--   * Found hole: _ :: Int -> String+--   * In the expression: _+--     In the expression: _ a+--     In an equation for ‘foo’: foo a = _ a+--   * Relevant bindings include+--       a :: Int+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)+--       foo :: Int -> String+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)+--     Valid hole fits include+--       foo :: Int -> String+--         (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)+--       show :: forall a. Show a => a -> String+--         with show @Int+--         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37+--          (and originally defined in ‘GHC.Show’))+--       mempty :: forall a. Monoid a => a+--         with mempty @(Int -> String)+--         (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37+--          (and originally defined in ‘GHC.Base’)) (lsp-ui)++    | topOfHoleFitsMarker `T.isInfixOf` _message = let+      findSuggestedHoleFits :: T.Text -> [T.Text]+      findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines+      proposeHoleFit name = ("replace hole `" <> holeName <>  "` with " <> name, [TextEdit _range name])+      holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message+      dropPreceding       = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))+      selectLinesWithFits = filter ("::" `T.isInfixOf`)+      extractFitNames     = map (T.strip . head . T.splitOn " :: ")+      in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message++    | otherwise = []++suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]+suggestExtendImport contents Diagnostic{_range=_range,..}+    | Just [binding, mod, srcspan] <-+      matchRegex _message+      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"+    , Just c <- contents+    = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of+            [s] -> let x = srcSpanToRange s+                   in x{_end = (_end x){_character = succ (_character (_end x))}}+            _ -> error "bug in srcspan parser"+          importLine = textInRange range c+        in [("Add " <> binding <> " to the import list of " <> mod+        , [TextEdit range (addBindingToImportList binding importLine)])]+    | otherwise = []++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] <-+    matchRegex _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{..},..}+    | "Top-level binding with no type signature" `T.isInfixOf` _message = let+      signature      = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message+      startOfLine    = Position (_line _start) 0+      beforeLine     = Range startOfLine startOfLine+      title          = if isQuickFix then "add signature: " <> signature else signature+      action         = TextEdit beforeLine $ signature <> "\n"+      in [(title, [action])]+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}+    | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let+      signature      = removeInitialForAll+                     $ T.takeWhile (\x -> x/='*' && x/='•')+                     $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message+      startOfLine    = Position (_line _start) (_character _start)+      beforeLine     = Range startOfLine startOfLine+      title          = if isQuickFix then "add signature: " <> signature else signature+      action         = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "+      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+suggestSignature _ _ = []++topOfHoleFitsMarker :: T.Text+topOfHoleFitsMarker =+#if MIN_GHC_API_VERSION(8,6,0)+  "Valid hole fits include"+#else+  "Valid substitutions include"+#endif++mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit+mkRenameEdit contents range name =+    if fromMaybe False maybeIsInfixFunction+      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 (map 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 x@IEThingAll{}) | 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 :: T.Text -> T.Text -> T.Text+addBindingToImportList binding importLine = case T.breakOn "(" importLine of+    (pre, T.uncons -> Just (_, rest)) ->+      case T.uncons (T.dropWhile isSpace rest) of+        Just (')', _) -> T.concat [pre, "(", binding, rest]+        _             -> T.concat [pre, "(", binding, ", ", rest]+    _ ->+      error+        $  "importLine does not have the expected structure: "+        <> T.unpack importLine++-- | Returns Just (the submatches) for the first capture, or Nothing.+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]+matchRegex message regex = case unifySpaces message =~~ regex of+    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings+    Nothing -> Nothing++setHandlersCodeLens :: PartialHandlers+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.codeLensHandler = withResponse RspCodeLens codeLens,+    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand+    }++filterNewlines :: T.Text -> T.Text+filterNewlines = T.concat  . T.lines++unifySpaces :: T.Text -> T.Text+unifySpaces    = T.unwords . T.words++--------------------------------------------------------------------------------++type PositionIndexedString = [(Position, Char)]++indexedByPosition :: String -> PositionIndexedString+indexedByPosition = unfoldr f . (Position 0 0,) 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))++-- | Returns a tuple (before, contents, after)+unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)+unconsRange Range {..} indexedString = (before, mid, after)+  where+    (before, rest) = span ((/= _start) . fst) indexedString+    (mid, after) = span ((/= _end) . fst) rest++stripRange :: Range -> PositionIndexedString -> PositionIndexedString+stripRange r s = case unconsRange r s of+  (b, _, a) -> b ++ a++extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]+extendAllToIncludeCommaIfPossible _             [] =  []+extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr+  where+    r' = case extendToIncludeCommaIfPossible indexedString r of+          [] -> r+          r' : _ -> r'+    indexedString' = stripRange r' indexedString++-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]+extendToIncludeCommaIfPossible indexedString range =+    -- a, |b|, c ===> a|, b|, c+    [ range{_start = start'}+    | (start', ',') : _ <- [before']+    ]+    +++    -- a, |b|, c ===> a, |b, |c+    [ range{_end = end'}+    |  (_, ',') : rest <- [after']+    , let (end', _) : _ = dropWhile (isSpace . snd) rest+    ]+  where+    (before, _, after) = unconsRange range indexedString+    after' = dropWhile (isSpace . snd) after+    before' = dropWhile (isSpace . snd) (reverse before)

@@ -0,0 +1,88 @@+{-# LANGUAGE TypeFamilies #-}++module Development.IDE.Plugin.Completions(plugin) 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 Language.Haskell.LSP.Types.Capabilities+import Development.Shake.Classes+import Development.Shake+import GHC.Generics+import Data.Maybe+import HscTypes++import Development.IDE.Plugin+import Development.IDE.Core.Service+import Development.IDE.Plugin.Completions.Logic+import Development.IDE.Types.Location+import Development.IDE.Core.PositionMapping+import Development.IDE.Core.RuleTypes+import Development.IDE.Core.Shake+import Development.IDE.GHC.Util+import Development.IDE.LSP.Server+import Development.IDE.Import.DependencyInformation+++plugin :: Plugin+plugin = Plugin produceCompletions setHandlersCompletion++produceCompletions :: Rules ()+produceCompletions =+    define $ \ProduceCompletions file -> do+        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file+        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)+        tm <- fmap fst <$> useWithStale TypeCheck file+        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file+        case (tm, packageState) of+            (Just tm', Just packageState') -> do+                cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')+                                                    (tmrModule tm') (map tmrModule tms)+                return ([], Just (cdata, tm'))+            _ -> return ([], Nothing)+++-- | Produce completions info for a file+type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)++data ProduceCompletions = ProduceCompletions+    deriving (Eq, Show, Typeable, Generic)+instance Hashable ProduceCompletions+instance NFData   ProduceCompletions+instance Binary   ProduceCompletions+++-- | Generate code actions.+getCompletionsLSP+    :: LSP.LspFuncs ()+    -> 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) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)+        case compls of+          Just ((cci', tm'), mapping) -> do+            let position' = fromCurrentPosition mapping position+            pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'+            case (pfix, completionContext) of+              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})+                -> return (Completions $ List [])+              (Just pfix', _) -> do+                let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing+                Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)+              _ -> return (Completions $ List [])+          _ -> return (Completions $ List [])+      _ -> return (Completions $ List [])++setHandlersCompletion :: PartialHandlers+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{+    LSP.completionHandler = withResponse RspCompletion getCompletionsLSP+    }

@@ -0,0 +1,534 @@+{-# LANGUAGE CPP #-}+-- Mostly taken from "haskell-ide-engine"+module Development.IDE.Plugin.Completions.Logic (+  CachedCompletions+, cacheDataProducer+, WithSnippets(..)+,getCompletions+) where++import Control.Applicative+import Data.Char (isSpace, isUpper)+import Data.Generics+import Data.List as List hiding (stripPrefix)+import qualified Data.Map  as Map+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text as T+import qualified Text.Fuzzy as Fuzzy++import GHC+import HscTypes+import Name+import RdrName+import TcRnTypes+import Type+import Var+import Packages+import DynFlags++import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import qualified Language.Haskell.LSP.VFS as VFS+import Development.IDE.Plugin.Completions.Types+import Development.IDE.Spans.Documentation+import Development.IDE.GHC.Error+import Development.IDE.Types.Options+import Development.IDE.Spans.Common+import Development.IDE.GHC.Util++-- 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++mkCompl :: IdeOptions -> CompItem -> CompletionItem+mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =+  CompletionItem label kind ((colon <>) <$> typeText)+    (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')+    Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+    Nothing Nothing Nothing Nothing Nothing+  where kind = Just $ occNameToComKind typeText $ occName 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+        docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs+        colon = if optNewColonConvention then ": " else ":: "++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 " " $ zipWith 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)+      | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)+      | otherwise = []++mkModCompl :: T.Text -> CompletionItem+mkModCompl label =+  CompletionItem label (Just CiModule) 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) (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++mkPragmaCompl :: T.Text -> T.Text -> CompletionItem+mkPragmaCompl label insertText =+  CompletionItem label (Just CiKeyword) Nothing+    Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)+    Nothing Nothing Nothing Nothing Nothing++cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions+cacheDataProducer packageState dflags tm tcs = do+  let parsedMod = tm_parsed_module tm+      curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod+      Just (_,limports,_,_) = tm_renamed_source tm++      iDeclToModName :: ImportDecl name -> ModuleName+      iDeclToModName = unLoc . ideclName++      showModName :: ModuleName -> T.Text+      showModName = T.pack . moduleNameString++      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++      typeEnv = tcg_type_env $ fst $ tm_internals_ tm+      rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm+      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 _) =+        case lookupTypeEnv typeEnv n of+          Just tt -> case safeTyThingId tt of+            Just var -> (\x -> ([x],mempty)) <$> varToCompl var+            Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n+          Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n+      getComplsForOne (GRE n _ False prov) =+        flip foldMapM (map is_decl prov) $ \spec -> do+          compItem <- toCompItem (is_mod spec) n+          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)++      varToCompl :: Var -> IO CompItem+      varToCompl var = do+        let typ = Just $ varType var+            name = Var.varName var+            label = T.pack $ showGhc name+        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name+        return $ CI name (showModName curMod) typ label Nothing docs++      toCompItem :: ModuleName -> Name -> IO CompItem+      toCompItem mn n = do+        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n+-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi+-- and leads to fun errors like "Cannot continue after interface file error".+#ifdef GHC_LIB+        let ty = Right Nothing+#else+        ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do+                name' <- lookupName n+                return $ name' >>= safeTyThingType+#endif+        return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs++  (unquals,quals) <- getCompls rdrElts++  return $ CC+    { allModNamesAsNS = allModNamesAsNS+    , unqualCompls = unquals+    , qualCompls = quals+    , importableModules = moduleNames+    }++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 = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)++-- | Returns the cached completions for the given module and position.+getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }+               tm prefixInfo caps withSnippets = do+  let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo+      enteredQual = if T.null prefixModule then "" else prefixModule <> "."+      fullPrefix  = enteredQual <> prefixText++      -- default to value context if no explicit context+      context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)++      {- correct the position by moving 'foo :: Int -> String ->    '+                                                                    ^+          to                             'foo :: Int -> String ->    '+                                                              ^+      -}+      pos =+        let Position l c = VFS.cursorPos prefixInfo+            typeStuff = [isSpace, (`elem` (">-." :: String))]+            stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)+            -- if oldPos points to+            -- foo -> bar -> baz+            --    ^+            -- Then only take the line up to there, discard '-> bar -> baz'+            partialLine = T.take c fullLine+            -- drop characters used when writing incomplete type sigs+            -- like '-> '+            d = T.length fullLine - T.length (stripTypeStuff partialLine)+        in Position l (c - d)++      filtModNameCompls =+        map mkModCompl+          $ mapMaybe (T.stripPrefix enteredQual)+          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS++      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False+        where+          isTypeCompl = isTcOcc . occName . origName+          -- completions specific to the current context+          ctxCompls' = case context of+                        TypeContext -> filter isTypeCompl compls+                        ValueContext -> filter (not . isTypeCompl) compls+                        _ -> 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 (VFS.cursorPos prefixInfo)++          compls = if T.null prefixModule+            then 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 = if T.null prefixModule then filtListWith mkExtCompl keywords else []++      stripLeading :: Char -> String -> String+      stripLeading _ [] = []+      stripLeading c (s:ss)+        | s == c = ss+        | otherwise = s:ss++      result+        | "import " `T.isPrefixOf` fullLine+        = filtImportCompls+        | "{-# language" `T.isPrefixOf` T.toLower fullLine+        = filtOptsCompls languagesAndExts+        | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine+        = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)+        | "{-# " `T.isPrefixOf` fullLine+        = filtPragmaCompls (pragmaSuffix fullLine)+        | otherwise+        = filtModNameCompls ++ map (toggleSnippets caps withSnippets+                                      . mkCompl ideOpts . stripAutoGenerated) filtCompls+                            ++ filtKeywordCompls+  +  return result++-- The supported languages and extensions+languagesAndExts :: [T.Text]+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions+  +-- ---------------------------------------------------------------------+-- 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"+  ]++keywords :: [T.Text]+keywords =+  [+    -- From https://wiki.haskell.org/Keywords+    "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"+  ]

@@ -0,0 +1,58 @@+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           GHC++import Development.IDE.Spans.Common++-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs++data Backtick = Surrounded | LeftSide deriving Show+data CompItem = CI+  { origName     :: Name           -- ^ Original name, such as Maybe, //, or find.+  , importedFrom :: T.Text         -- ^ From where this item is imported from.+  , thingType    :: Maybe Type     -- ^ 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.+  }+instance Show CompItem where+  show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""+                   ++ ", importedFrom = " ++ show importedFrom+                   ++ ", thingType = " ++ show (fmap showGhc thingType)+                   ++ ", label = " ++ show label+                   ++ ", isInfix = " ++ show isInfix +                   ++ ", docs = " ++ show docs+                   ++ " } "+instance Eq CompItem where+  ci1 == ci2 = origName ci1 == origName ci2+instance Ord CompItem where+  compare ci1 ci2 = origName ci1 `compare` origName ci2++-- 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

@@ -8,7 +8,6 @@   , gotoDefinition   ) where -import           Development.IDE.Spans.Documentation import           Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location@@ -18,7 +17,8 @@ import Development.IDE.GHC.Util import Development.IDE.GHC.Compat import Development.IDE.Types.Options-import           Development.IDE.Spans.Type as SpanInfo+import Development.IDE.Spans.Type as SpanInfo+import Development.IDE.Spans.Common (spanDocToMarkdown)  -- GHC API imports import Avail@@ -27,6 +27,8 @@ import Name import Outputable hiding ((<>)) import SrcLoc+import Type+import VarSet  import Control.Monad.Extra import Control.Monad.Trans.Maybe@@ -50,41 +52,52 @@ -- | Synopsis for the name at a given position. atPoint   :: IdeOptions-  -> [TypecheckedModule]-  -> [SpanInfo]+  -> SpansInfo   -> Position   -> Maybe (Maybe Range, [T.Text])-atPoint IdeOptions{..} tcs srcSpans pos = do+atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do     firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans-    return (Just (range firstSpan), hoverInfo firstSpan)+    let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)+    return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)   where     -- Hover info for types, classes, type variables-    hoverInfo SpanInfo{spaninfoType = Nothing , ..} =-       documentation <> (wrapLanguageSyntax <$> name <> kind) <> location+    hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs ,  ..} _ =+       (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs      where-       documentation = findDocumentation mbName        name     = [maybe shouldNotHappen showName  mbName]        location = [maybe shouldNotHappen definedAt mbName]-       kind     = [] -- TODO        shouldNotHappen = "ghcide: did not expect a type level component without a name"        mbName = getNameM spaninfoSource      -- Hover info for values/data-    hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =-       documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location+    hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =+       (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs      where        mbName = getNameM spaninfoSource-       documentation  = findDocumentation mbName-       typeAnnotation = [colon <> showName typ]-       nameOrSource   = [maybe literalSource qualifyNameIfPossible mbName]-       literalSource = "" -- TODO: literals: display (length-limited) source+       expr = case spaninfoSource of+                Named n -> qualifyNameIfPossible n+                Lit   l -> crop $ T.pack l+                _       -> ""+       nameOrSource   = [expr <> "\n" <> typeAnnotation]        qualifyNameIfPossible name' = modulePrefix <> showName name'          where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')        location = [maybe "" definedAt mbName] -    findDocumentation = maybe [] (getDocumentation tcs)-    definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"+       thisFVs = tyCoVarsOfType typ+       constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts+       constraintsT = T.intercalate ", " (map showName constraintsOverFVs) +       typeAnnotation = case constraintsOverFVs of +                          []  -> colon <> showName typ+                          [_] -> colon <> constraintsT <> "\n=> " <> showName typ+                          _   -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ++    definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"++    crop txt+      | T.length txt > 50 = T.take 46 txt <> " ..."+      | otherwise         = txt+     range SpanInfo{..} = Range       (Position spaninfoStartLine spaninfoStartCol)       (Position spaninfoEndLine spaninfoEndCol)@@ -112,6 +125,7 @@   where getSpan :: SpanSource -> m (Maybe SrcSpan)         getSpan NoSource = pure Nothing         getSpan (SpanS sp) = pure $ Just sp+        getSpan (Lit _) = pure Nothing         getSpan (Named name) = case nameSrcSpan name of             sp@(RealSrcSpan _) -> pure $ Just sp             sp@(UnhelpfulSpan _) -> runMaybeT $ do@@ -119,7 +133,7 @@                 -- 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.-                let mod = nameModule name+                mod <- MaybeT $ return $ nameModule_maybe name                 let unitId = moduleUnitId mod                 pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState                 hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod@@ -133,7 +147,7 @@                 pure span         -- 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 n == nameModule n'+        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 

@@ -9,13 +9,11 @@  -- | Get information on modules, identifiers, etc. -module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where+module Development.IDE.Spans.Calculate(getSrcSpanInfos) where  import           ConLike import           Control.Monad import qualified CoreUtils-import           Data.Data-import qualified Data.Generics import           Data.List import           Data.Maybe import           DataCon@@ -26,14 +24,19 @@ import           OccName import           Development.IDE.Types.Location import           Development.IDE.Spans.Type+#ifdef GHC_LIB import           Development.IDE.GHC.Error (zeroSpan)+#else+import           Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)+#endif import           Prelude hiding (mod) import           TcHsSyn import           Var import Development.IDE.Core.Compile import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Util-+import Development.IDE.Spans.Common+import Development.IDE.Spans.Documentation  -- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore -- this U ignores that arg in 8.6, but is hidden in 8.4@@ -48,37 +51,44 @@     :: HscEnv     -> [(Located ModuleName, Maybe NormalizedFilePath)]     -> TcModuleResult-    -> IO [SpanInfo]-getSrcSpanInfos env imports tc =-    runGhcEnv env-        . getSpanInfo imports-        $ tmrModule tc+    -> [TcModuleResult]+    -> IO SpansInfo+getSrcSpanInfos env imports tc tms =+    runGhcEnv env $+        getSpanInfo imports (tmrModule tc) (map tmrModule tms)  -- | Get ALL source spans in the module. getSpanInfo :: GhcMonad m             => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports             -> TypecheckedModule-            -> m [SpanInfo]-getSpanInfo mods tcm =+            -> [TypecheckedModule]+            -> m SpansInfo+getSpanInfo mods tcm tcms =   do let tcs = tm_typechecked_source tcm          bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]          ps  = listifyAllSpans' tcs :: [Pat GhcTc]          ts  = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]-     let funBinds = funBindMap $ tm_parsed_module tcm-     bts <- mapM (getTypeLHsBind funBinds) bs -- binds-     ets <- mapM (getTypeLHsExpr tcm) es -- expressions-     pts <- mapM (getTypeLPat tcm)    ps -- patterns-     tts <- mapM (getLHsType tcm)     ts -- types+         allModules = tcm:tcms+         funBinds = funBindMap $ tm_parsed_module tcm+     bts <- mapM (getTypeLHsBind allModules funBinds) bs   -- binds+     ets <- mapM (getTypeLHsExpr allModules) es -- expressions+     pts <- mapM (getTypeLPat allModules)    ps -- patterns+     tts <- mapM (getLHsType allModules)     ts -- types      let imports = importInfo mods      let exports = getExports tcm-     let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)-     return (mapMaybe toSpanInfo (sortBy cmp exprs))-  where cmp (_,a,_) (_,b,_)+     let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)+     let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)+     return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))+                        (mapMaybe toSpanInfo (sortBy cmp constraints))+  where cmp (_,a,_,_) (_,b,_,_)           | a `isSubspanOf` b = LT           | b `isSubspanOf` a = GT           | otherwise         = compare (srcSpanStart a) (srcSpanStart b) +        addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))+        constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)+ -- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always -- points to the first match) whereas the parsed module has the correct locations. -- Therefore we build up a map from OccName to the corresponding definition in the parsed module@@ -88,10 +98,10 @@ funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs) funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ] -getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)] getExports m     | Just (_, _, Just exports, _) <- renamedSource m =-    [ (Named $ unLoc n, getLoc n, Nothing)+    [ (Named $ unLoc n, getLoc n)     | (e, _) <- exports     , n <- ieLNames $ unLoc e     ]@@ -107,47 +117,96 @@  -- | Get the name and type of a binding. getTypeLHsBind :: (GhcMonad m)-               => OccEnv (HsBind GhcPs)+               => [TypecheckedModule]+               -> OccEnv (HsBind GhcPs)                -> LHsBind GhcTc-               -> m [(SpanSource, SrcSpan, Maybe Type)]-getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})-  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =-  return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]+               -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]+getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})+  | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do+  let name = getName (unLoc pid)+  docs <- getDocumentationTryGhc tms name+  return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.-getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =-  return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]-getTypeLHsBind _ _ = return []+getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do+  let name = getName (unLoc pid)+  docs <- getDocumentationTryGhc tms name+  return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]+getTypeLHsBind _ _ _ = return [] +-- | Get information about constraints+getConstraintsLHsBind :: LHsBind GhcTc+                      -> [(SrcSpan, Type)]+getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })+  = map (\v -> (spn, varType v)) vars+getConstraintsLHsBind _ = []+ -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m)-               => TypecheckedModule+               => [TypecheckedModule]                -> LHsExpr GhcTc-               -> m (Maybe (SpanSource, SrcSpan, Maybe Type))-getTypeLHsExpr _ e = do+               -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))+getTypeLHsExpr tms e = do   hs_env <- getSession   (_, mbe) <- liftIO (deSugarExpr hs_env e)-  return $-    case mbe of-      Just expr ->-        Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))-      Nothing -> Nothing+  case mbe of+    Just expr -> do+      let ss = getSpanSource (unLoc e)+      docs <- case ss of+                Named n -> getDocumentationTryGhc tms n+                _       -> return emptySpanDoc+      return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)+    Nothing -> return Nothing   where     getSpanSource :: HsExpr GhcTc -> SpanSource+    getSpanSource xpr | isLit xpr = Lit (showGhc xpr)     getSpanSource (HsVar U (L _ i)) = Named (getName i)     getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)     getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)     getSpanSource (HsWrap U _ xpr) = getSpanSource xpr     getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)-    getSpanSource _ =  NoSource+    getSpanSource _ = NoSource +    isLit :: HsExpr GhcTc -> Bool+    isLit (HsLit U _) = True+    isLit (HsOverLit U _) = True+    isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args+#if MIN_GHC_API_VERSION(8,6,0)+    isLit (ExplicitSum  U _ _ xpr) = isLitChild (unLoc xpr)+    isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs+#else+    isLit (ExplicitSum  _ _ xpr _) = isLitChild (unLoc xpr)+    isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs+#endif+    isLit _ = False++    isTupLit (Present U xpr) = isLitChild (unLoc xpr)+    isTupLit _               = False++    -- We need special treatment for children so things like [(1)] are still treated+    -- as a list literal while not treating (1) as a literal.+    isLitChild (HsWrap U _ xpr) = isLitChild xpr+    isLitChild (HsPar U xpr)    = isLitChild (unLoc xpr)+#if MIN_GHC_API_VERSION(8,8,0)+    isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)+#elif MIN_GHC_API_VERSION(8,6,0)+    isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)+#else+    isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)+    isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)+#endif+    isLitChild e = isLit e+ -- | Get the name and type of a pattern. getTypeLPat :: (GhcMonad m)-            => TypecheckedModule+            => [TypecheckedModule]             -> Pat GhcTc-            -> m (Maybe (SpanSource, SrcSpan, Maybe Type))-getTypeLPat _ pat =-  let (src, spn) = getSpanSource pat in-  return $ Just (src, spn, Just (hsPatType pat))+            -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))+getTypeLPat tms pat = do+  let (src, spn) = getSpanSource pat+  docs <- case src of+            Named n -> getDocumentationTryGhc tms n+            _       -> return emptySpanDoc+  return $ Just (src, spn, Just (hsPatType pat), docs)   where     getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)     getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)@@ -157,40 +216,40 @@  getLHsType     :: GhcMonad m-    => TypecheckedModule+    => [TypecheckedModule]     -> LHsType GhcRn-    -> m [(SpanSource, SrcSpan, Maybe Type)]-getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]+    -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]+getLHsType tms (L spn (HsTyVar U _ v)) = do+  let n = unLoc v+  docs <- getDocumentationTryGhc tms n+#ifdef GHC_LIB+  let ty = Right Nothing+#else+  ty <- catchSrcErrors "completion" $ do+          name' <- lookupName n+          return $ name' >>= safeTyThingType+#endif+  let ty' = case ty of+              Right (Just x) -> Just x+              _ -> Nothing+  pure [(Named n, spn, ty', docs)] getLHsType _ _ = pure []  importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]-           -> [(SpanSource, SrcSpan, Maybe Type)]+           -> [(SpanSource, SrcSpan)] importInfo = mapMaybe (uncurry wrk) where-  wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)+  wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)   wrk modName = \case     Nothing -> Nothing-    Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)+    Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)    -- TODO make this point to the module name   fpToSpanSource :: FilePath -> SpanSource   fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp --- | Get ALL source spans in the source.-listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]-listifyAllSpans tcs =-  Data.Generics.listify p tcs-  where p (L spn _) = isGoodSrcSpan spn--- This is a version of `listifyAllSpans` specialized on picking out--- patterns.  It comes about since GHC now defines `type LPat p = Pat--- p` (no top-level locations).-listifyAllSpans' :: Typeable a-                   => TypecheckedSource -> [Pat a]-listifyAllSpans' tcs = Data.Generics.listify (const True) tcs-- -- | Pretty print the types into a 'SpanInfo'.-toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo-toSpanInfo (name,mspan,typ) =+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo+toSpanInfo (name,mspan,typ,docs) =   case mspan of     RealSrcSpan spn ->       -- GHC’s line and column numbers are 1-based while LSP’s line and column@@ -200,5 +259,6 @@                      (srcSpanEndLine spn - 1)                      (srcSpanEndCol spn - 1)                      typ-                     name)+                     name+                     docs)     _ -> Nothing

@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}+#include "ghc-api-version.h"++module Development.IDE.Spans.Common (+  showGhc+, listifyAllSpans+, listifyAllSpans'+, safeTyThingId+#ifndef GHC_LIB+, safeTyThingType+#endif+, SpanDoc(..)+, emptySpanDoc+, spanDocToMarkdown+, spanDocToMarkdownForTest+) where++import Data.Data+import qualified Data.Generics+import qualified Data.Text as T++import GHC+import Outputable+import DynFlags+import ConLike+import DataCon+#ifndef GHC_LIB+import Var+#endif++import           Data.Char (isSpace)+import qualified Documentation.Haddock.Parser as H+import qualified Documentation.Haddock.Types as H++showGhc :: Outputable a => a -> String+showGhc = showPpr unsafeGlobalDynFlags++-- | Get ALL source spans in the source.+listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]+listifyAllSpans tcs =+  Data.Generics.listify p tcs+  where p (L spn _) = isGoodSrcSpan spn+-- This is a version of `listifyAllSpans` specialized on picking out+-- patterns.  It comes about since GHC now defines `type LPat p = Pat+-- p` (no top-level locations).+listifyAllSpans' :: Typeable a+                   => TypecheckedSource -> [Pat a]+listifyAllSpans' tcs = Data.Generics.listify (const True) tcs++#ifndef GHC_LIB+-- 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+#endif++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+  | SpanDocText   [T.Text]+  deriving Show++emptySpanDoc :: SpanDoc+emptySpanDoc = SpanDocText []++spanDocToMarkdown :: SpanDoc -> [T.Text]+#if MIN_GHC_API_VERSION(8,6,0)+spanDocToMarkdown (SpanDocString docs)+  = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]+#else+spanDocToMarkdown (SpanDocString _)+  = []+#endif+spanDocToMarkdown (SpanDocText txt) = txt++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)+  = s+haddockToMarkdown (H.DocParagraph p)+  = "\n\n" ++ haddockToMarkdown p+haddockToMarkdown (H.DocIdentifier i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocIdentifierUnchecked i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocModule i)+  = "`" ++ i ++ "`"+haddockToMarkdown (H.DocWarning w)+  = haddockToMarkdown w+haddockToMarkdown (H.DocEmphasis d)+  = "*" ++ haddockToMarkdown d ++ "*"+haddockToMarkdown (H.DocBold d)+  = "**" ++ haddockToMarkdown d ++ "**"+haddockToMarkdown (H.DocMonospaced d)+  = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"+  where+    escapeBackticks "" = ""+    escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss+    escapeBackticks (s  :ss) = s:escapeBackticks ss+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)+  = "[" ++ aname ++ "]:"+haddockToMarkdown (H.DocHeader (H.Header level title))+  = replicate level '#' ++ " " ++ haddockToMarkdown title++haddockToMarkdown (H.DocUnorderedList things)+  = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)+haddockToMarkdown (H.DocOrderedList things)+  = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . 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++splitForList :: String -> String+splitForList s+  = case lines s of+      [] -> ""+      (first:rest) -> unlines $ first : map (("  " ++) . dropWhile isSpace) rest

@@ -15,32 +15,28 @@ import           Data.Maybe import qualified Data.Text as T import           Development.IDE.GHC.Error-import           Development.IDE.Spans.Calculate+import           Development.IDE.Spans.Common import           FastString import           GHC import SrcLoc -#if MIN_GHC_API_VERSION(8,6,0)-import           Data.Char (isSpace)-import           Development.IDE.GHC.Util-import qualified Documentation.Haddock.Parser as H-import qualified Documentation.Haddock.Types as H-#endif  getDocumentationTryGhc-  :: HscEnv-  -> [TypecheckedModule]+  :: GhcMonad m+  => [TypecheckedModule]   -> Name-  -> IO [T.Text]-#if MIN_GHC_API_VERSION(8,6,0)-getDocumentationTryGhc packageState tcs name = do-  res <- runGhcEnv packageState $ catchSrcErrors "docs" $ getDocs name+  -> m SpanDoc+-- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.+-- See https://github.com/digital-asset/daml/issues/4152 for more details.+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)+getDocumentationTryGhc tcs name = do+  res <- catchSrcErrors "docs" $ getDocs name   case res of-    Right (Right (Just docs, _)) -> return [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]-    _ -> return $ getDocumentation tcs name+    Right (Right (Just docs, _)) -> return $ SpanDocString docs+    _ -> return $ SpanDocText $ getDocumentation tcs name #else-getDocumentationTryGhc _packageState tcs name = do-  return $ getDocumentation tcs name+getDocumentationTryGhc tcs name = do+  return $ SpanDocText $ getDocumentation tcs name #endif  getDocumentation@@ -115,81 +111,3 @@                             then Just $ T.pack s                             else Nothing     _ -> Nothing--#if MIN_GHC_API_VERSION(8,6,0)--- 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)-  = s-haddockToMarkdown (H.DocParagraph p)-  = "\n\n" ++ haddockToMarkdown p-haddockToMarkdown (H.DocIdentifier i)-  = "`" ++ i ++ "`"-haddockToMarkdown (H.DocIdentifierUnchecked i)-  = "`" ++ i ++ "`"-haddockToMarkdown (H.DocModule i)-  = "`" ++ i ++ "`"-haddockToMarkdown (H.DocWarning w)-  = haddockToMarkdown w-haddockToMarkdown (H.DocEmphasis d)-  = "*" ++ haddockToMarkdown d ++ "*"-haddockToMarkdown (H.DocBold d)-  = "**" ++ haddockToMarkdown d ++ "**"-haddockToMarkdown (H.DocMonospaced d)-  = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"-  where-    escapeBackticks "" = ""-    escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss-    escapeBackticks (s  :ss) = s:escapeBackticks ss-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 ++ ">"-#if MIN_VERSION_haddock_library(1,8,0)-haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))-  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"-#else-haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))-  = "[" ++ label ++ "](" ++ url ++ ")"-#endif-haddockToMarkdown (H.DocPic (H.Picture url Nothing))-  = "![](" ++ url ++ ")"-haddockToMarkdown (H.DocPic (H.Picture url (Just label)))-  = "![" ++ label ++ "](" ++ url ++ ")"-haddockToMarkdown (H.DocAName aname)-  = "[" ++ aname ++ "]:"-haddockToMarkdown (H.DocHeader (H.Header level title))-  = replicate level '#' ++ " " ++ haddockToMarkdown title--haddockToMarkdown (H.DocUnorderedList things)-  = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)-haddockToMarkdown (H.DocOrderedList things)-  = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) 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-#endif

@@ -6,7 +6,8 @@ -- | Types used separate to GHCi vanilla.  module Development.IDE.Spans.Type(-    SpanInfo(..)+    SpansInfo(..)+  , SpanInfo(..)   , SpanSource(..)   , getNameM   ) where@@ -15,7 +16,16 @@ import Control.DeepSeq import OccName import Development.IDE.GHC.Util+import Development.IDE.Spans.Common +data SpansInfo =+  SpansInfo { spansExprs       :: [SpanInfo]+            , spansConstraints :: [SpanInfo] }+  deriving Show++instance NFData SpansInfo where+  rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c+ -- | Type of some span of source code. Most of these fields are -- unboxed but Haddock doesn't show that. data SpanInfo =@@ -34,11 +44,14 @@             -- any. This can be useful for accessing a variety of             -- information about the identifier such as module,             -- locality, definition location, etc.+           ,spaninfoDocs :: !SpanDoc+           -- ^ Documentation for the element            } instance Show SpanInfo where-  show (SpanInfo sl sc el ec t n) =+  show (SpanInfo sl sc el ec t n docs) =     unwords ["(SpanInfo", show sl, show sc, show el, show ec-            , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]+            , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"+            , "docs(" <> show docs <> ")"]  instance NFData SpanInfo where     rnf = rwhnf@@ -47,6 +60,7 @@ -- we don't always get a name out so sometimes manually annotating source is more appropriate data SpanSource = Named Name                 | SpanS SrcSpan+                | Lit String                 | NoSource   deriving (Eq) @@ -54,6 +68,7 @@   show = \case     Named n -> "Named " ++ occNameString (occName n)     SpanS sp -> "Span " ++ show sp+    Lit lit -> "Lit " ++ lit     NoSource -> "NoSource"  getNameM :: SpanSource -> Maybe Name

@@ -47,24 +47,57 @@   , toNormalizedUri   , fromNormalizedUri   )-import GHC+import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP+import GHC.Generics   -- | Newtype wrapper around FilePath that always has normalized slashes.-newtype NormalizedFilePath = NormalizedFilePath FilePath-    deriving (Eq, Ord, Show, Hashable, NFData, Binary)+-- The NormalizedUri and hash of the FilePath are cached to avoided+-- repeated normalisation when we need to compute them (which is a lot).+--+-- This is one of the most performance critical parts of ghcide, do not+-- modify it without profiling.+data NormalizedFilePath = NormalizedFilePath NormalizedUriWrapper !Int !FilePath+    deriving (Generic, Eq, Ord) +instance NFData NormalizedFilePath where+instance Binary NormalizedFilePath where+  put (NormalizedFilePath _ _ fp) = put fp+  get = do+    v <- Data.Binary.get :: Get FilePath+    return (toNormalizedFilePath v)+++instance Show NormalizedFilePath where+  show (NormalizedFilePath _ _ fp) = "NormalizedFilePath " ++ show fp++instance Hashable NormalizedFilePath where+  hash (NormalizedFilePath _ h _) = h++-- Just to define NFData and Binary+newtype NormalizedUriWrapper =+  NormalizedUriWrapper { unwrapNormalizedFilePath :: NormalizedUri }+  deriving (Show, Generic, Eq, Ord)++instance NFData NormalizedUriWrapper where+  rnf = rwhnf+++instance Hashable NormalizedUriWrapper where+ instance IsString NormalizedFilePath where     fromString = toNormalizedFilePath  toNormalizedFilePath :: FilePath -> NormalizedFilePath -- We want to keep empty paths instead of normalising them to "."-toNormalizedFilePath "" = NormalizedFilePath ""-toNormalizedFilePath fp = NormalizedFilePath $ normalise fp+toNormalizedFilePath "" = NormalizedFilePath (NormalizedUriWrapper emptyPathUri) (hash ("" :: String)) ""+toNormalizedFilePath fp =+  let nfp = normalise fp+  in NormalizedFilePath (NormalizedUriWrapper $ filePathToUriInternal' nfp) (hash nfp) nfp  fromNormalizedFilePath :: NormalizedFilePath -> FilePath-fromNormalizedFilePath (NormalizedFilePath fp) = fp+fromNormalizedFilePath (NormalizedFilePath _ _ fp) = fp  -- | 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@@ -76,10 +109,13 @@     | otherwise = LSP.uriToFilePath uri  emptyPathUri :: NormalizedUri-emptyPathUri = filePathToUri' ""+emptyPathUri = filePathToUriInternal' ""  filePathToUri' :: NormalizedFilePath -> NormalizedUri-filePathToUri' (NormalizedFilePath fp) = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp+filePathToUri' (NormalizedFilePath (NormalizedUriWrapper u) _ _) = u++filePathToUriInternal' :: FilePath -> NormalizedUri+filePathToUriInternal' fp = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp   where     -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that     -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost.

@@ -15,21 +15,30 @@ import Data.Char (toLower) import Data.Foldable import Data.List+import Data.Rope.UTF16 (Rope)+import qualified Data.Rope.UTF16 as Rope+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) import Development.IDE.GHC.Util import qualified Data.Text as T+import Development.IDE.Spans.Common import Development.IDE.Test import Development.IDE.Test.Runfiles import Development.IDE.Types.Location-import Language.Haskell.LSP.Test+import qualified Language.Haskell.LSP.Test as LSPTest+import Language.Haskell.LSP.Test hiding (openDoc') import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities+import Language.Haskell.LSP.VFS (applyChange) import System.Environment.Blank (setEnv) import System.FilePath import System.IO.Extra import System.Directory+import Test.QuickCheck+import Test.QuickCheck.Instances () import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck import Data.Maybe  main :: IO ()@@ -52,6 +61,8 @@   , preprocessorTests   , thTests   , unitTests+  , haddockTests+  , positionMappingTests   ]  initializeResponseTests :: TestTree@@ -391,10 +402,12 @@   , typeWildCardActionTests   , removeImportTests   , extendImportTests+  , addExtensionTests   , fixConstructorImportTests   , importRenameActionTests   , fillTypedHoleTests   , addSigActionTests+  , insertNewDefinitionTests   ]  codeLensesTests :: TestTree@@ -412,9 +425,7 @@             ]       doc <- openDoc' "Testing.hs" "haskell" content       _ <- waitForDiagnostics-      [CACodeAction action@CodeAction { _title = actionTitle }]-          <- getCodeActions doc (Range (Position 2 14) (Position 2 20))-      liftIO $ "Replace with ‘argName’" @=? actionTitle+      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"       executeCodeAction action       contentAfterAction <- documentContents doc       let expectedContentAfterAction = T.unlines@@ -432,9 +443,7 @@             ]       doc <- openDoc' "Testing.hs" "haskell" content       _ <- waitForDiagnostics-      [CACodeAction action@CodeAction { _title = actionTitle }]-          <- getCodeActions doc (Range (Position 3 6) (Position 3 16))-      liftIO $ "Replace with ‘maybeToList’" @=? actionTitle+      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"       executeCodeAction action       contentAfterAction <- documentContents doc       let expectedContentAfterAction = T.unlines@@ -452,10 +461,9 @@             ]       doc <- openDoc' "Testing.hs" "haskell" content       _ <- waitForDiagnostics-      actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))-      let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]-          expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]-      liftIO $ expectedActionTitles @=? actionTitles+      _ <- 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"@@ -809,6 +817,117 @@       contentAfterAction <- documentContents docB       liftIO $ expectedContentB @=? contentAfterAction +addExtensionTests :: TestTree+addExtensionTests = testGroup "add language extension actions"+  [ testSession "add NamedFieldPuns language extension" $ template+      (T.unlines+            [ "module Module where"+            , ""+            , "data A = A { getA :: Bool }"+            , ""+            , "f :: A -> Bool"+            , "f A { getA } = getA"+            ])+      (Range (Position 0 0) (Position 0 0))+      "Add NamedFieldPuns extension"+      (T.unlines+            [ "{-# LANGUAGE NamedFieldPuns #-}"+            , "module Module where"+            , ""+            , "data A = A { getA :: Bool }"+            , ""+            , "f :: A -> Bool"+            , "f A { getA } = getA"+            ])+  , testSession "add RecordWildCards language extension" $ template+      (T.unlines+            [ "module Module where"+            , ""+            , "data A = A { getA :: Bool }"+            , ""+            , "f :: A -> Bool"+            , "f A { .. } = getA"+            ])+      (Range (Position 0 0) (Position 0 0))+      "Add RecordWildCards extension"+      (T.unlines+            [ "{-# LANGUAGE RecordWildCards #-}"+            , "module Module where"+            , ""+            , "data A = A { getA :: Bool }"+            , ""+            , "f :: A -> Bool"+            , "f A { .. } = getA"+            ])+  ]+    where+      template initialContent range expectedAction expectedContents = do+        doc <- openDoc' "Module.hs" "haskell" initialContent+        _ <- waitForDiagnostics+        CACodeAction action@CodeAction { _title = actionTitle } : _+                    <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+                       getCodeActions doc range+        liftIO $ expectedAction @=? actionTitle+        executeCodeAction action+        contentAfterAction <- documentContents doc+        liftIO $ expectedContents @=? contentAfterAction+++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 <- openDoc' "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 <- openDoc' "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')+  ]+ fixConstructorImportTests :: TestTree fixConstructorImportTests = testGroup "fix import actions"   [ testSession "fix constructor import" $ template@@ -1032,7 +1151,7 @@         _ -> 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 <> ":")+  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")    checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()   checkHoverRange expectedRange rangeInHover msg =@@ -1094,14 +1213,14 @@   mclL37 = Position 37  1   spaceL37 = Position 37  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]   docL41 = Position 41  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]-                           ;  constr = [ExpectHoverText ["Monad m =>"]]+                           ;  constr = [ExpectHoverText ["Monad m"]]   eitL40 = Position 40 28  ;  kindE  = [ExpectHoverText [":: * -> * -> *\n"]]   intL40 = Position 40 34  ;  kindI  = [ExpectHoverText [":: *\n"]]   tvrL40 = Position 40 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]   intL41 = Position 41 20  ;  litI   = [ExpectHoverText ["7518"]]-  chrL36 = Position 36 25  ;  litC   = [ExpectHoverText ["'t'"]]-  txtL8  = Position  8 14  ;  litT   = [ExpectHoverText ["\"dfgv\""]]-  lstL43 = Position 43 12  ;  litL   = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]+  chrL36 = Position 37 24  ;  litC   = [ExpectHoverText ["'f'"]]+  txtL8  = Position  8 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]+  lstL43 = Position 43 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]   outL45 = Position 45  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]   innL48 = Position 48  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]   in@@ -1132,14 +1251,14 @@   , test yes    yes    mclL37 mcl    "top-level fn 2nd clause         #246"   , test yes    yes    spaceL37 space "top-level fn on space #315"   , test no     broken docL41 doc    "documentation                     #7"-  , test no     broken eitL40 kindE  "kind of Either                  #273"-  , test no     broken intL40 kindI  "kind of Int                     #273"+  , 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 no     yes    intL41 litI   "literal Int  in hover info      #274"+  , test no     yes    chrL36 litC   "literal Char in hover info      #274"+  , test no     yes    txtL8  litT   "literal Text in hover info      #274"+  , test no     yes    lstL43 litL   "literal List in hover info      #274"+  , test no     yes    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"   ]@@ -1172,22 +1291,35 @@  cppTests :: TestTree cppTests =-  testCase "cpp" $ 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)-              )+  testGroup "cpp"+    [ 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+        _ <- openDoc' "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@@ -1251,11 +1383,11 @@         let source = T.unlines ["module A where", "f = hea"]         docId <- openDoc' "A.hs" "haskell" source         compls <- getCompletions docId (Position 1 7)-        liftIO $ map dropDocs compls @?= +        liftIO $ map dropDocs compls @?=           [complItem "head" (Just CiFunction) (Just "[a] -> a")]         let [CompletionItem { _documentation = headDocs}] = compls         checkDocText "head" headDocs [ "Defined in 'Prelude'"-#if MIN_GHC_API_VERSION(8,6,0)+#if MIN_GHC_API_VERSION(8,6,5)                                      , "Extract the first element of a list" #endif                                      ]@@ -1263,12 +1395,12 @@         let source = T.unlines ["module A where", "f = Tru"]         docId <- openDoc' "A.hs" "haskell" source         compls <- getCompletions docId (Position 1 7)-        liftIO $ map dropDocs compls @?= +        liftIO $ map dropDocs compls @?=           [ complItem "True" (Just CiConstructor) (Just "Bool") #if MIN_GHC_API_VERSION(8,6,0)           , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b") #else-          , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") +          , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") #endif           ]     , testSessionWait "type" $ do@@ -1283,7 +1415,7 @@         let [ CompletionItem { _documentation = boundedDocs},               CompletionItem { _documentation = boolDocs } ] = compls         checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"-#if MIN_GHC_API_VERSION(8,6,0)+#if MIN_GHC_API_VERSION(8,6,5)                                            , "name the upper and lower limits" #endif                                            ]@@ -1294,14 +1426,19 @@         expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]         changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]         compls <- getCompletions docId (Position 2 15)-        liftIO $ map dropDocs compls @?= +        liftIO $ map dropDocs compls @?=           [complItem "head" (Just CiFunction) (Just "[a] -> a")]         let [CompletionItem { _documentation = headDocs}] = compls         checkDocText "head" headDocs [ "Defined in 'Prelude'"-#if MIN_GHC_API_VERSION(8,6,0)+#if MIN_GHC_API_VERSION(8,6,5)                                      , "Extract the first element of a list" #endif                                      ]+    , testSessionWait "keyword" $ do+        let source = T.unlines ["module A where", "f = newty"]+        docId <- openDoc' "A.hs" "haskell" source+        compls <- getCompletions docId (Position 1 9)+        liftIO $ compls @?= [keywordItem "newtype"]     ]   where     dropDocs :: CompletionItem -> CompletionItem@@ -1323,6 +1460,23 @@       , _command = Nothing       , _xdata = Nothing       }+    keywordItem label = CompletionItem+      { _label = label+      , _kind = Just CiKeyword+      , _detail = Nothing+      , _documentation = Nothing+      , _deprecated = Nothing+      , _preselect = Nothing+      , _sortText = Nothing+      , _filterText = Nothing+      , _insertText = Nothing+      , _insertTextFormat = Nothing+      , _textEdit = Nothing+      , _additionalTextEdits = Nothing+      , _commitCharacters = Nothing+      , _command = Nothing+      , _xdata = Nothing+      }     getDocText (CompletionDocString s) = s     getDocText (CompletionDocMarkup (MarkupContent _ s)) = s     checkDocText thing Nothing _@@ -1494,6 +1648,62 @@  mkR :: Int -> Int -> Int -> Int -> Expect mkR startLine startColumn endLine endColumn = ExpectRange $ 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+ ---------------------------------------------------------------------- -- Utils @@ -1532,7 +1742,8 @@   -- HIE calls getXgdDirectory which assumes that HOME is set.   -- Only sets HOME if it wasn't already set.   setEnv "HOME" "/homeless-shelter" False-  runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s+  let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }+  runSessionWithConfig conf cmd lspTestCaps dir s   where     conf = defaultConfig       -- If you uncomment this you can see all logging@@ -1546,9 +1757,208 @@   source <- liftIO $ readFileUtf8 $ "test/data" </> path   openDoc' path "haskell" source +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]+findCodeActions doc range expectedTitles = do+  actions <- getCodeActions doc range+  let matches = sequence+        [ listToMaybe+          [ action+          | CACodeAction action@CodeAction { _title = actionTitle } <- actions+          , actionTitle == expectedTitle ]+        | expectedTitle <- expectedTitles]+  let msg = show+            [ actionTitle+            | CACodeAction CodeAction { _title = actionTitle } <- actions+            ]+            ++ "is not a superset of "+            ++ 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" $          uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""      ]++-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier+openDoc' fp name contents = do+  res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents+  sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])+  return res++positionMappingTests :: TestTree+positionMappingTests =+    testGroup "position mapping"+        [ testGroup "toCurrent"+              [ testCase "before" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= Just (Position 0 0)+              , testCase "after, same line, same length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= Just (Position 0 3)+              , testCase "after, same line, increased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 3) @?= Just (Position 0 4)+              , testCase "after, same line, decreased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 3) @?= Just (Position 0 2)+              , testCase "after, next line, no newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= Just (Position 1 3)+              , testCase "after, next line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 1 0) @?= Just (Position 2 0)+              , testCase "after, same line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 0 4) @?= Just (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) @?= Just (Position 2 1)+              , testCase "after, same line, newline + newline at end" $+                toCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 1) @?= Just (Position 0 4)+              ]+        , testGroup "fromCurrent"+              [ testCase "before" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= Just (Position 0 0)+              , testCase "after, same line, same length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= Just (Position 0 3)+              , testCase "after, same line, increased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 4) @?= Just (Position 0 3)+              , testCase "after, same line, decreased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 2) @?= Just (Position 0 3)+              , testCase "after, next line, no newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= Just (Position 1 3)+              , testCase "after, next line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 2 0) @?= Just (Position 1 0)+              , testCase "after, same line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 1 2) @?= Just (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) @?= Just (Position 0 4)+              , testCase "after, same line, newline + newline at end" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 4) @?= Just (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) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $+                    \(range, replacement, oldPos, newPos) ->+                    fromCurrent range replacement newPos === Just 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) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $+                    \(range, replacement, newPos, oldPos) ->+                    toCurrent range replacement oldPos === Just 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