diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -224,10 +224,8 @@ { "languageserver": { "haskell": { - "command": "stack", + "command": "ghcide", "args": [ - "exec", - "ghcide", "--lsp" ], "rootPatterns": [ diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -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 diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -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 -> diff --git a/src/Development/IDE/Core/Completions.hs b/src/Development/IDE/Core/Completions.hs deleted file mode 100644 --- a/src/Development/IDE/Core/Completions.hs +++ /dev/null @@ -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" - ] diff --git a/src/Development/IDE/Core/CompletionsTypes.hs b/src/Development/IDE/Core/CompletionsTypes.hs deleted file mode 100644 --- a/src/Development/IDE/Core/CompletionsTypes.hs +++ /dev/null @@ -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 diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -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 diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/FileExists.hs @@ -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] ] diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -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. diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -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 diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -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 diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -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 diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -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 diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -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 () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -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 diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -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 diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -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). diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -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 diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs deleted file mode 100644 --- a/src/Development/IDE/LSP/CodeAction.hs +++ /dev/null @@ -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) diff --git a/src/Development/IDE/LSP/Completions.hs b/src/Development/IDE/LSP/Completions.hs deleted file mode 100644 --- a/src/Development/IDE/LSP/Completions.hs +++ /dev/null @@ -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 - } diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -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 diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -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. diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -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 } diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -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 } })) diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -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 diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin.hs @@ -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 diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -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) diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/Completions.hs @@ -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 + } diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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" + ] diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -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 diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -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 diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Spans/Common.hs @@ -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 diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -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 diff --git a/src/Development/IDE/Spans/Type.hs b/src/Development/IDE/Spans/Type.hs --- a/src/Development/IDE/Spans/Type.hs +++ b/src/Development/IDE/Spans/Type.hs @@ -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 diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -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. diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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