diff --git a/.gitignore b/.gitignore index 391cea0db2..f2807263aa 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,7 @@ stack*.yaml.lock shake.yaml.lock .vscode -/test-logs/ +/test-logs/*.log # stack 2.1 stack.yaml lock files stack*.yaml.lock diff --git a/cabal.project b/cabal.project index 6c5b39f913..92e6aaa60b 100644 --- a/cabal.project +++ b/cabal.project @@ -16,4 +16,4 @@ package ghcide write-ghc-environment-files: never -index-state: 2020-02-09T06:58:05Z +index-state: 2020-03-03T21:14:55Z diff --git a/exe/Arguments.hs b/exe/Arguments.hs index 926b9b7b54..e495a82565 100644 --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -30,7 +30,13 @@ data Arguments = Arguments ,argFiles :: [FilePath] ,argsVersion :: Bool ,argsShakeProfiling :: Maybe FilePath + ,argsTesting :: Bool ,argsExamplePlugin :: Bool + -- These next two are for compatibility with existing hie clients, allowing + -- them to just change the name of the exe and still work. + , argsDebugOn :: Bool + , argsLogFile :: Maybe String + } getArguments :: String -> IO Arguments @@ -45,15 +51,29 @@ arguments :: String -> Parser Arguments arguments exeName = Arguments <$> switch (long "lsp" <> help "Start talking to an LSP server") <*> optional (strOption $ long "cwd" <> metavar "DIR" - <> help "Change to this directory") + <> help "Change to this directory") <*> many (argument str (metavar "FILES/DIRS...")) <*> switch (long "version" <> help ("Show " ++ exeName ++ " and GHC versions")) <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" - <> help "Dump profiling reports to this directory") + <> help "Dump profiling reports to this directory") + <*> switch (long "test" + <> help "Enable additional lsp messages used by the testsuite") <*> switch (long "example" <> help "Include the Example Plugin. For Plugin devs only") + <*> switch + ( long "debug" + <> short 'd' + <> help "Generate debug output" + ) + <*> optional (strOption + ( long "logfile" + <> short 'l' + <> metavar "LOGFILE" + <> help "File to log to, defaults to stdout" + )) + -- --------------------------------------------------------------------- -- Set the GHC libdir to the nix libdir if it's present. getLibdir :: IO FilePath diff --git a/exe/Main.hs b/exe/Main.hs index ffc323e113..816c321f2b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,10 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Main(main) where @@ -14,11 +16,14 @@ import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import Data.Default +import qualified Data.HashSet as HashSet import Data.List.Extra import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T +-- import Data.Version +-- import Development.GitRev import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest @@ -34,19 +39,22 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action, action) -import GHC hiding (def) +import Development.Shake (Action, Rules, action) import HIE.Bios -import Ide.Plugin.Formatter +import qualified Language.Haskell.LSP.Core as LSP +import Ide.Logger +import Ide.Plugin import Ide.Plugin.Config import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) -import Linker -import qualified Data.HashSet as HashSet -import System.Directory.Extra as IO +import RuleTypes +import Rules +import qualified System.Directory.Extra as IO +-- import System.Environment import System.Exit import System.FilePath import System.IO +import System.Log.Logger as L import System.Time.Extra -- --------------------------------------------------------------------- @@ -54,24 +62,60 @@ import System.Time.Extra import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Completions as Completions import Ide.Plugin.Example as Example +import Ide.Plugin.Example2 as Example2 import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Ormolu as Ormolu +import Ide.Plugin.Pragmas as Pragmas -- --------------------------------------------------------------------- --- The plugins configured for use in this instance of the language +-- | The plugins configured for use in this instance of the language -- server. -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> Plugin Config -idePlugins includeExample - = Completions.plugin <> - CodeAction.plugin <> - formatterPlugins [("ormolu", Ormolu.provider) - ,("floskell", Floskell.provider)] <> - if includeExample then Example.plugin else mempty +idePlugins :: T.Text -> Bool -> (Plugin Config, [T.Text]) +idePlugins pid includeExamples + = (asGhcIdePlugin ps, allLspCmdIds' pid ps) + where + ps = pluginDescToIdePlugins allPlugins + allPlugins = if includeExamples + then basePlugins ++ examplePlugins + else basePlugins + basePlugins = + [ + -- applyRefactDescriptor "applyrefact" + -- , brittanyDescriptor "brittany" + -- , haddockDescriptor "haddock" + -- -- , hareDescriptor "hare" + -- , hsimportDescriptor "hsimport" + -- , liquidDescriptor "liquid" + -- , packageDescriptor "package" + Pragmas.descriptor "pragmas" + , Floskell.descriptor "floskell" + -- , genericDescriptor "generic" + -- , ghcmodDescriptor "ghcmod" + , Ormolu.descriptor "ormolu" + ] + examplePlugins = + [Example.descriptor "eg" + ,Example2.descriptor "eg2" + -- ,hfaAlignDescriptor "hfaa" + ] + -- --------------------------------------------------------------------- +-- Prefix for the cache path +{- +cacheDir :: String +cacheDir = "ghcide" + +getCacheDir :: [String] -> IO FilePath +getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) +-} main :: IO () main = do @@ -82,40 +126,57 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + -- LSP.setupLogger (optLogFile opts) ["hie", "hie-bios"] + -- $ if optDebugOn opts then L.DEBUG else L.INFO + LSP.setupLogger argsLogFile ["hie", "hie-bios"] + $ if argsDebugOn then L.DEBUG else L.INFO + -- lock to avoid overlapping output on stdout lock <- newLock let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - whenJust argsCwd setCurrentDirectory + whenJust argsCwd IO.setCurrentDirectory - dir <- getCurrentDirectory + dir <- IO.getCurrentDirectory - let plugins = idePlugins argsExamplePlugin + pid <- getPid + let + -- (ps, commandIds) = idePlugins pid argsExamplePlugin + (ps, commandIds) = idePlugins pid True + plugins = Completions.plugin <> CodeAction.plugin <> + ps + options = def { LSP.executeCommandCommands = Just commandIds + , LSP.completionTriggerCharacters = Just "." + } if argLSP then do t <- offsetTime hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do + runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \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) + let options = (defaultIdeOptions $ loadSession dir) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling + , optTesting = argsTesting } debouncer <- newAsyncDebouncer - initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs + initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) + getLspId event hlsLogger debouncer options vfs else do + -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir files <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM canonicalizePath files + files <- nubOrd <$> mapM IO.canonicalizePath files putStrLn $ "Found " ++ show (length files) ++ " files" putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup" @@ -129,7 +190,8 @@ main = do cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x when (isNothing x) $ print cradle putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session" - cradleToSession cradle + opts <- getComponentOptions cradle + createSession opts putStrLn "\nStep 5/6: Initializing the IDE" vfs <- makeVFSHandle @@ -142,7 +204,7 @@ main = do let options = (defaultIdeOptions $ return $ return . grab) { optShakeProfiling = argsShakeProfiling } - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs + ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files @@ -156,6 +218,10 @@ main = do unless (null failed) exitFailure +cradleRules :: Rules () +cradleRules = do + loadGhcSession + cradleToSession expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do @@ -164,7 +230,7 @@ expandFiles = concatMapM $ \x -> do let recurse "." = True recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x + files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files @@ -182,37 +248,21 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e - -cradleToSession :: Cradle a -> IO HscEnvEq -cradleToSession cradle = do - cradleRes <- getCompilerOptions "" cradle - opts <- case cradleRes of - CradleSuccess r -> pure r - CradleFail err -> throwIO err - -- TODO Rather than failing here, we should ignore any files that use this cradle. - -- That will require some more changes. - CradleNone -> fail "'none' cradle is not yet supported" - libdir <- getLibdir - env <- runGhc (Just libdir) $ do - _targets <- initSession opts - getSession - initDynLinker env - newHscEnvEq env - - -loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq) -loadSession dir = do +loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq) +loadSession dir = liftIO $ do cradleLoc <- memoIO $ \v -> do res <- findCradle v -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path -- try and normalise that -- e.g. see https://github.com/digital-asset/ghcide/issues/126 - res' <- traverse makeAbsolute res + res' <- traverse IO.makeAbsolute res return $ normalise <$> res' - session <- memoIO $ \file -> do - c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file - cradleToSession c - return $ \file -> liftIO $ session =<< cradleLoc file + let session :: Maybe FilePath -> Action HscEnvEq + session file = do + -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle + let cradle = toNormalizedFilePath $ fromMaybe dir file + use_ LoadCradle cradle + return $ \file -> session =<< liftIO (cradleLoc file) -- | Memoize an IO function, with the characteristics: diff --git a/exe/RuleTypes.hs b/exe/RuleTypes.hs new file mode 100644 index 0000000000..8520eaa44a --- /dev/null +++ b/exe/RuleTypes.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module RuleTypes (GetHscEnv(..), LoadCradle(..)) where + +import Control.DeepSeq +import Data.Binary +import Data.Hashable (Hashable) +import Development.Shake +import Development.IDE.GHC.Util +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +-- Rule type for caching GHC sessions. +type instance RuleResult GetHscEnv = HscEnvEq + +data GetHscEnv = GetHscEnv + { hscenvOptions :: [String] -- componentOptions from hie-bios + , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios + } + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetHscEnv +instance NFData GetHscEnv +instance Binary GetHscEnv + +-- Rule type for caching cradle loading +type instance RuleResult LoadCradle = HscEnvEq + +data LoadCradle = LoadCradle + deriving (Eq, Show, Typeable, Generic) + +instance Hashable LoadCradle +instance NFData LoadCradle +instance Binary LoadCradle diff --git a/exe/Rules.hs b/exe/Rules.hs new file mode 100644 index 0000000000..00b6e178ca --- /dev/null +++ b/exe/Rules.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Rules + ( loadGhcSession + , cradleToSession + , cradleLoadedMethod + , createSession + , getComponentOptions + ) +where + +import Control.Exception +import Control.Monad (filterM, when) +import qualified Crypto.Hash.SHA1 as H +import Data.ByteString.Base16 (encode) +import qualified Data.ByteString.Char8 as B +import Data.Functor ((<&>)) +import Data.Maybe (fromMaybe) +import Data.Text (pack, Text) +import Development.IDE.Core.Rules (defineNoFile) +import Development.IDE.Core.Service (getIdeOptions) +import Development.IDE.Core.Shake (actionLogger, sendEvent, define, useNoFile_) +import Development.IDE.GHC.Util +import Development.IDE.Types.Location (fromNormalizedFilePath) +import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting)) +import Development.Shake +import DynFlags (gopt_set, gopt_unset, + updOptLevel) +import GHC +import qualified GHC.Paths +import HIE.Bios +import HIE.Bios.Cradle +import HIE.Bios.Environment (addCmdOpts) +import HIE.Bios.Types +import Linker (initDynLinker) +import RuleTypes +import qualified System.Directory.Extra as IO +import System.Environment (lookupEnv) +import System.FilePath.Posix (addTrailingPathSeparator, + ()) +import Language.Haskell.LSP.Messages as LSP +import Language.Haskell.LSP.Types as LSP +import Data.Aeson (ToJSON(toJSON)) +import Development.IDE.Types.Logger (logDebug) + +-- Prefix for the cache path +cacheDir :: String +cacheDir = "ghcide" + +notifyCradleLoaded :: FilePath -> LSP.FromServerMessage +notifyCradleLoaded fp = + LSP.NotCustomServer $ + LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $ + toJSON fp + +loadGhcSession :: Rules () +loadGhcSession = + -- This rule is for caching the GHC session. E.g., even when the cabal file + -- changed, if the resulting flags did not change, we would continue to use + -- the existing session. + defineNoFile $ \(GetHscEnv opts deps) -> + liftIO $ createSession $ ComponentOptions opts deps + +cradleToSession :: Rules () +cradleToSession = define $ \LoadCradle nfp -> do + + let f = fromNormalizedFilePath nfp + + IdeOptions{optTesting} <- getIdeOptions + + logger <- actionLogger + liftIO $ logDebug logger $ "Running cradle " <> pack (fromNormalizedFilePath nfp) + + -- If the path points to a directory, load the implicit cradle + mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f + cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml + + when optTesting $ + sendEvent $ notifyCradleLoaded f + + -- Avoid interrupting `getComponentOptions` since it calls external processes + cmpOpts <- liftIO $ mask $ \_ -> getComponentOptions cradle + let opts = componentOptions cmpOpts + deps = componentDependencies cmpOpts + deps' = case mbYaml of + -- For direct cradles, the hie.yaml file itself must be watched. + Just yaml | isDirectCradle cradle -> yaml : deps + _ -> deps + existingDeps <- filterM doesFileExist deps' + need existingDeps + ([],) . pure <$> useNoFile_ (GetHscEnv opts deps) + +cradleLoadedMethod :: Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +getComponentOptions :: Cradle a -> IO ComponentOptions +getComponentOptions cradle = do + let showLine s = putStrLn ("> " ++ s) + -- WARNING 'runCradle is very expensive and must be called as few times as possible + cradleRes <- runCradle (cradleOptsProg cradle) showLine "" + case cradleRes of + CradleSuccess r -> pure r + CradleFail err -> throwIO err + -- TODO Rather than failing here, we should ignore any files that use this cradle. + -- That will require some more changes. + CradleNone -> fail "'none' cradle is not yet supported" + +createSession :: ComponentOptions -> IO HscEnvEq +createSession (ComponentOptions theOpts _) = do + libdir <- getLibdir + + cacheDir <- getCacheDir theOpts + + env <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + (dflags', _targets) <- addCmdOpts theOpts dflags + _ <- setSessionDynFlags $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setHiDir cacheDir $ + setDefaultHieDir cacheDir $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation dflags' + getSession + initDynLinker env + newHscEnvEq env + +-- Set the GHC libdir to the nix libdir if it's present. +getLibdir :: IO FilePath +getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +getCacheDir :: [String] -> IO FilePath +getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index bb73bd7f67..f8dcaccf65 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -18,7 +18,8 @@ import Data.List -- import qualified Data.Text.IO as T -- import Development.IDE.Types.Logger import HIE.Bios -import Ide.Cradle (findLocalCradle, logm) +import Ide.Cradle (findLocalCradle) +import Ide.Logger (logm) import Ide.Version import System.Directory import System.Environment diff --git a/ghcide b/ghcide index 286635bac8..8b328bb7c5 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 286635bac84c573ca2fbafc6a65d633302b152d1 +Subproject commit 8b328bb7c5f3e09280788b56abd6fb6d0bfb08ce diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d3847c81af..a3076a8af3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -27,12 +27,18 @@ source-repository head library exposed-modules: + Ide.Compat Ide.Cradle + Ide.Logger + Ide.Plugin Ide.Plugin.Config Ide.Plugin.Example + Ide.Plugin.Example2 Ide.Plugin.Ormolu + Ide.Plugin.Pragmas Ide.Plugin.Floskell Ide.Plugin.Formatter + Ide.Types Ide.Version other-modules: Paths_haskell_language_server @@ -59,6 +65,7 @@ library , haskell-lsp == 0.20.* , hie-bios >= 0.4 , hslogger + , lens , optparse-simple , process , regex-tdfa >= 1.3.1.0 @@ -66,6 +73,10 @@ library , text , transformers , unordered-containers + if os(windows) + build-depends: Win32 + else + build-depends: unix if impl(ghc >= 8.6) build-depends: ormolu >= 0.0.3.1 @@ -85,6 +96,8 @@ executable haskell-language-server other-modules: Arguments Paths_haskell_language_server + Rules + RuleTypes autogen-modules: Paths_haskell_language_server ghc-options: @@ -103,8 +116,14 @@ executable haskell-language-server build-depends: base >=4.7 && <5 + , aeson + , base16-bytestring + , binary + , bytestring + , cryptohash-sha1 , containers , data-default + , deepseq , extra , filepath -------------------------------------------------------------- @@ -118,9 +137,11 @@ executable haskell-language-server , ghc-paths , ghcide , gitrev + , hashable , haskell-lsp , hie-bios >= 0.4 , haskell-language-server + , hslogger , optparse-applicative , shake >= 0.17.5 , text @@ -176,10 +197,13 @@ test-suite func-test base >=4.7 && <5 , aeson , data-default + , haskell-lsp-types , hls-test-utils + , hspec + , lens , lsp-test >= 0.10.0.0 , text - , hspec + , unordered-containers other-modules: -- CompletionSpec -- , CommandSpec @@ -195,6 +219,7 @@ test-suite func-test -- , HieBiosSpec -- , HighlightSpec -- , HoverSpec + , PluginSpec -- , ProgressSpec -- , ReferencesSpec -- , RenameSpec diff --git a/src/Ide/Compat.hs b/src/Ide/Compat.hs new file mode 100644 index 0000000000..f46ffa3f56 --- /dev/null +++ b/src/Ide/Compat.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module Ide.Compat + ( + getProcessID + ) where + +#ifdef mingw32_HOST_OS + +import qualified System.Win32.Process as P (getCurrentProcessId) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getCurrentProcessId + +#else + +import qualified System.Posix.Process as P (getProcessID) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getProcessID + +#endif diff --git a/src/Ide/Cradle.hs b/src/Ide/Cradle.hs index f6a5a4e1db..b27782544e 100644 --- a/src/Ide/Cradle.hs +++ b/src/Ide/Cradle.hs @@ -6,7 +6,6 @@ module Ide.Cradle where import Control.Exception -import Control.Monad.IO.Class import Data.Foldable (toList) import Data.Function ((&)) import Data.List (isPrefixOf, sortOn, find) @@ -24,6 +23,7 @@ import Distribution.Helper (Package, projectPackages, pUnits, Unit, unitInfo, uiComponents, ChEntrypoint(..), UnitInfo(..)) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) +import Ide.Logger import HIE.Bios as Bios import qualified HIE.Bios.Cradle as Bios import HIE.Bios.Types (CradleAction(..)) @@ -31,7 +31,6 @@ import qualified HIE.Bios.Types as Bios import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable) import System.Exit import System.FilePath -import System.Log.Logger import System.Process (readCreateProcessWithExitCode, shell, CreateProcess(..)) @@ -903,17 +902,3 @@ cradleDisplay cradle = fromString result name = Bios.actionName (Bios.cradleOptsProg cradle) -- --------------------------------------------------------------------- - -logm :: MonadIO m => String -> m () -logm s = liftIO $ infoM "hie" s - -debugm :: MonadIO m => String -> m () -debugm s = liftIO $ debugM "hie" s - -warningm :: MonadIO m => String -> m () -warningm s = liftIO $ warningM "hie" s - -errorm :: MonadIO m => String -> m () -errorm s = liftIO $ errorM "hie" s - --- --------------------------------------------------------------------- diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs new file mode 100644 index 0000000000..9bb8468146 --- /dev/null +++ b/src/Ide/Logger.hs @@ -0,0 +1,43 @@ +{- | Provides an implementation of the ghcide @Logger@ which uses + @System.Log.Logger@ under the hood. +-} +module Ide.Logger + ( + hlsLogger + , logm + , debugm + , warningm + , errorm + ) where + +import Control.Monad.IO.Class +import qualified Data.Text as T +import qualified Development.IDE.Types.Logger as L +import System.Log.Logger + +-- --------------------------------------------------------------------- + +hlsLogger :: L.Logger +hlsLogger = L.Logger $ \pri txt -> + case pri of + L.Telemetry -> logm (T.unpack txt) + L.Debug -> debugm (T.unpack txt) + L.Info -> logm (T.unpack txt) + L.Warning -> warningm (T.unpack txt) + L.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +logm :: MonadIO m => String -> m () +logm s = liftIO $ infoM "hie" s + +debugm :: MonadIO m => String -> m () +debugm s = liftIO $ debugM "hie" s + +warningm :: MonadIO m => String -> m () +warningm s = liftIO $ warningM "hie" s + +errorm :: MonadIO m => String -> m () +errorm s = liftIO $ errorM "hie" s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs new file mode 100644 index 0000000000..2f1a36498f --- /dev/null +++ b/src/Ide/Plugin.hs @@ -0,0 +1,548 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Plugin + ( + asGhcIdePlugin + , pluginDescToIdePlugins + , mkLspCommand + , allLspCmdIds + , allLspCmdIds' + , getPid + , responseError + ) where + +import Control.Lens ( (^.) ) +import Control.Monad +import qualified Data.Aeson as J +import qualified Data.Default +import Data.Either +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Plugin hiding (pluginRules) +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Logger +import Development.Shake hiding ( Diagnostic, command ) +import GHC.Generics +import Ide.Compat +import Ide.Plugin.Config +import Ide.Plugin.Formatter +import Ide.Types +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Capabilities as C +import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) +import qualified Language.Haskell.LSP.VFS as VFS +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +-- | Map a set of plugins to the underlying ghcide engine. Main point is +-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message +-- category ('Notifaction', 'Request' etc). +asGhcIdePlugin :: IdePlugins -> Plugin Config +asGhcIdePlugin mp = + mkPlugin rulesPlugins (Just . pluginRules) <> + mkPlugin executeCommandPlugins (Just . pluginCommands) <> + mkPlugin codeActionPlugins pluginCodeActionProvider <> + mkPlugin codeLensPlugins pluginCodeLensProvider <> + -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider + mkPlugin hoverPlugins pluginHoverProvider <> + mkPlugin symbolsPlugins pluginSymbolsProvider <> + mkPlugin formatterPlugins pluginFormattingProvider <> + mkPlugin completionsPlugins pluginCompletionProvider + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + + +pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins + +allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text] +allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + +-- --------------------------------------------------------------------- + +rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config +rulesPlugins rs = Plugin rules mempty + where + rules = mconcat $ map snd rs + +codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config +codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) + +codeActionRules :: Rules () +codeActionRules = mempty + +codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config +codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeActionHandler + = withResponse RspCodeAction (makeCodeAction cas) + } + +makeCodeAction :: [(PluginId, CodeActionProvider)] + -> LSP.LspFuncs Config -> IdeState + -> CodeActionParams + -> IO (Either ResponseError (List CAResult)) +makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do + let caps = LSP.clientCapabilities lf + unL (List ls) = ls + r <- mapM (\(pid,provider) -> provider ideState pid docId range context) cas + let actions = filter wasRequested . concat $ map unL $ rights r + res <- send caps actions + return $ Right res + where + wasRequested :: CAResult -> Bool + wasRequested (CACommand _) = True + wasRequested (CACodeAction ca) + | Nothing <- only context = True + | Just (List allowed) <- only context + , Just caKind <- ca ^. kind = caKind `elem` allowed + | otherwise = False + + wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) + wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) + wrapCodeAction caps (CACodeAction action) = do + + let (C.ClientCapabilities _ textDocCaps _ _) = caps + let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport + + case literalSupport of + Nothing -> do + let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + cmd <- mkLspCommand "hie" "fallbackCodeAction" (action ^. title) (Just cmdParams) + return $ Just (CACommand cmd) + Just _ -> return $ Just (CACodeAction action) + + send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) + send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions + +data FallbackCodeActionParams = + FallbackCodeActionParams + { fallbackWorkspaceEdit :: Maybe WorkspaceEdit + , fallbackCommand :: Maybe Command + } + deriving (Generic, J.ToJSON, J.FromJSON) + +-- ----------------------------------------------------------- + +codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config +codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) + +codeLensRules :: Rules () +codeLensRules = mempty + +codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config +codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeLensHandler + = withResponse RspCodeLens (makeCodeLens cas) + } + +makeCodeLens :: [(PluginId, CodeLensProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) +makeCodeLens cas _lf ideState params = do + logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ + let + makeLens (pid, provider) = do + r <- provider ideState pid params + return (pid, r) + breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) + breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) + where + doOneLeft (pid, Left err) = [(pid,err)] + doOneLeft (_, Right _) = [] + + doOneRight (pid, Right a) = [(pid,a)] + doOneRight (_, Left _) = [] + + r <- mapM makeLens cas + case breakdown r of + ([],[]) -> return $ Right $ List [] + (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing + (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) + +-- ----------------------------------------------------------- + +executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config +executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) + +executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config +executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) + } + +-- type ExecuteCommandProvider = IdeState +-- -> ExecuteCommandParams +-- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider +makeExecuteCommands ecs _lf _params = do + let + pluginMap = Map.fromList ecs + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + execCmd (ExecuteCommandParams cmdId args _) = do + -- The parameters to the HIE command are always the first element + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hie", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + let eParams = J.ApplyWorkspaceEditParams edit + -- TODO: Use lspfuncs to send an applyedit message. Or change + -- the API to allow a list of messages to be returned. + return (Right J.Null, Just(J.WorkspaceApplyEdit, eParams)) + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) + Nothing -> return (Right J.Null, Nothing) + + J.Error _str -> return (Right J.Null, Nothing) + -- Couldn't parse the fallback command params + -- _ -> liftIO $ + -- LSP.sendErrorResponseS (LSP.sendFunc lf) + -- (J.responseId (req ^. J.id)) + -- J.InvalidParams + -- "Invalid fallbackCodeAction params" + + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand pluginMap plugin cmd cmdParams + + -- Couldn't parse the command identifier + _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) + + execCmd + +{- + ReqExecuteCommand req -> do + liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req + lf <- asks lspFuncs + + let params = req ^. J.params + + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + callback obj = do + liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj + case fromDynJSON obj :: Maybe J.WorkspaceEdit of + Just v -> do + lid <- nextLspReqId + reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v + liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg + reactorSend $ ReqApplyWorkspaceEdit msg + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj + + execCmd cmdId args = do + -- The parameters to the HIE command are always the first element + let cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> A.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hie", "fallbackCodeAction") -> do + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + lid <- nextLspReqId + let eParams = J.ApplyWorkspaceEditParams edit + eReq = fmServerApplyWorkspaceEditRequest lid eParams + reactorSend $ ReqApplyWorkspaceEdit eReq + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs + + -- Otherwise we need to send back a response oureslves + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + + -- Couldn't parse the fallback command params + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid fallbackCodeAction params" + -- Just an ordinary HIE command + Just (plugin, cmd) -> + let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit)) + $ runPluginCommand plugin cmd cmdParams + in makeRequest preq + + -- Couldn't parse the command identifier + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid command identifier" + + execCmd (params ^. J.command) (params ^. J.arguments) +-} + +-- ----------------------------------------------------------- + +-- | Runs a plugin command given a PluginId, CommandId and +-- arguments in the form of a JSON object. +runPluginCommand :: Map.Map PluginId [PluginCommand] -> PluginId -> CommandId -> J.Value + -> IO (Either ResponseError J.Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +runPluginCommand m p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p m of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return (Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return (Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Nothing, Nothing) + J.Success a -> f a + +-- ----------------------------------------------------------- + +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command +mkLspCommand plid cn title args' = do + pid <- getPid + let cmdId = mkLspCmdId pid plid cn + let args = List <$> args' + return $ Command title cmdId args + +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID + +allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text] +allLspCmdIds pid commands = concat $ map go commands + where + go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + +-- --------------------------------------------------------------------- + +hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config +hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) + +hoverRules :: Rules () +hoverRules = mempty + +hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config +hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} + +makeHover :: [(PluginId, HoverProvider)] + -> LSP.LspFuncs Config -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError (Maybe Hover)) +makeHover hps _lf ideState params + = do + mhs <- mapM (\(_,p) -> p ideState params) hps + -- TODO: We should support ServerCapabilities and declare that + -- we don't support hover requests during initialization if we + -- don't have any hover providers + -- TODO: maybe only have provider give MarkedString and + -- work out range here? + let hs = catMaybes (rights mhs) + r = listToMaybe $ mapMaybe (^. range) hs + h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of + HoverContentsMS (List []) -> Nothing + hh -> Just $ Hover hh r + return $ Right h + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config +symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) + +symbolsRules :: Rules () +symbolsRules = mempty + +symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config +symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} + +makeSymbols :: [(PluginId, SymbolsProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError DSResult) +makeSymbols sps lf ideState params + = do + let uri' = params ^. textDocument . uri + (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf + supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol + >>= C._hierarchicalDocumentSymbolSupport + convertSymbols :: [DocumentSymbol] -> DSResult + convertSymbols symbs + | supportsHierarchy = DSDocumentSymbols $ List symbs + | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) + where + go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] + go parent ds = + let children' :: [SymbolInformation] + children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) + loc = Location uri' (ds ^. range) + name' = ds ^. name + si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent + in [si] <> children' + + mhs <- mapM (\(_,p) -> p ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ convertSymbols $ concat hs + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config +formatterPlugins providers + = Plugin formatterRules + (formatterHandlers (Map.fromList (("none",noneProvider):providers))) + +formatterRules :: Rules () +formatterRules = mempty + +formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config +formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.documentFormattingHandler + = withResponse RspDocumentFormatting (formatting providers) + , LSP.documentRangeFormattingHandler + = withResponse RspDocumentRangeFormatting (rangeFormatting providers) + } + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config +completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) + +completionsRules :: Rules () +completionsRules = mempty + +completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config +completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} + +makeCompletions :: [(PluginId, CompletionProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) +makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) + = do + mprefix <- getPrefixAtPos lf doc pos + _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf) + + let + combine :: [CompletionResponseResult] -> CompletionResponseResult + combine cs = go (Completions $ List []) cs + where + go acc [] = acc + go (Completions (List ls)) (Completions (List ls2):rest) + = go (Completions (List (ls <> ls2))) rest + go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest) + = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + + case mprefix of + Nothing -> return $ Right $ Completions $ List [] + Just _prefix -> do + mhs <- mapM (\(_,p) -> p ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ combine hs + +{- + ReqCompletion req -> do + liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req + let (_, doc, pos) = reqParams req + + mprefix <- getPrefixAtPos doc pos + + let callback compls = do + let rspMsg = Core.makeResponseMessage req + $ J.Completions $ J.List compls + reactorSend $ RspCompletion rspMsg + case mprefix of + Nothing -> callback [] + Just prefix -> do + snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn + let hreq = IReq tn "completion" (req ^. J.id) callback + $ lift $ Completions.getCompletions doc prefix snippets + makeRequest hreq +-} + +getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) +getPrefixAtPos lf uri pos = do + mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) + case mvf of + Just vf -> VFS.getCompletionPrefix pos vf + Nothing -> return Nothing + +-- --------------------------------------------------------------------- +-- | Returns the current client configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can at runitime change +-- their configuration. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getClientConfig :: LSP.LspFuncs Config -> IO Config +getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 2908c865ae..0ea345cef3 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -1,65 +1,71 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Example ( - plugin + descriptor ) where import Control.DeepSeq ( NFData ) import Control.Monad.Trans.Maybe -import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Aeson import Data.Binary import Data.Functor import qualified Data.HashMap.Strict as Map -import Data.Hashable import qualified Data.HashSet as HashSet +import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.OfInterest -import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.LSP.Server -import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) import GHC.Generics -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages +import Ide.Plugin +import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -plugin :: Plugin c -plugin = Plugin exampleRules handlersExample - <> codeActionPlugin codeAction - <> Plugin mempty handlersCodeLens +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = exampleRules + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols + , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) hover = request "Hover" blah (Right Nothing) foundHover blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) - = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"]) - -handlersExample :: PartialHandlers c -handlersExample = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover $ const hover} - + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"]) -- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- data Example = Example deriving (Eq, Show, Typeable, Generic) @@ -97,39 +103,35 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) } -- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- -- | Generate code actions. codeAction - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> TextDocumentIdentifier -> Range -> CodeActionContext - -> IO (Either ResponseError [CAResult]) -codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + -> IO (Either ResponseError (List CAResult)) +codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let - title = "Add TODO Item" - tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) - "-- TODO added by Example Plugin directly\n"] + title = "Add TODO Item 1" + tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) + "-- TODO1 added by Example Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - pure $ Right + pure $ Right $ List [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] -- --------------------------------------------------------------------- --- | Generate code lenses. -handlersCodeLens :: PartialHandlers c -handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.codeLensHandler = withResponse RspCodeLens codeLens, - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand - } - codeLens - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath @@ -137,29 +139,36 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} _hDiag <- getHiddenDiagnostics ideState let title = "Add TODO Item via Code Lens" - tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) - "-- TODO added by Example Plugin via code lens action\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - range = (Range (Position 3 0) (Position 4 0)) - pure $ Right $ List - -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing - [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing - ] + -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + -- "-- TODO added by Example Plugin via code lens action\n"] + -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [(toJSON cmdParams)]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] --- | Execute the "codelens.todo" command. -executeAddSignatureCommand - :: LSP.LspFuncs c - -> IdeState - -> ExecuteCommandParams - -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} - | _command == "codelens.todo" - , Just (List [edit]) <- _arguments - , Success wedit <- fromJSON edit - = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) - | otherwise - = return (Null, Nothing) +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +addTodoCmd (AddTodoParams uri todoText) = do + let + pos = Position 3 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) -- --------------------------------------------------------------------- @@ -184,10 +193,54 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc Nothing -> pure Nothing pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do let filePath = toNormalizedFilePath path logInfo (ideLogger ide) $ label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path runAction ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider +symbols _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 2 0) (Position 2 5) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider +completion _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example completion" + kind = Nothing + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs new file mode 100644 index 0000000000..60f8d54d64 --- /dev/null +++ b/src/Ide/Plugin/Example2.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Example2 + ( + descriptor + ) where + +import Control.DeepSeq ( NFData ) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Binary +import Data.Functor +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as HashSet +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.OfInterest +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.Shake hiding ( Diagnostic ) +import GHC.Generics +import Ide.Plugin +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = exampleRules + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols + , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- + +hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +hover = request "Hover" blah (Right Nothing) foundHover + +blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) +blah _ (Position line col) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) + +-- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- + +data Example2 = Example2 + deriving (Eq, Show, Typeable, Generic) +instance Hashable Example2 +instance NFData Example2 +instance Binary Example2 + +type instance RuleResult Example2 = () + +exampleRules :: Rules () +exampleRules = do + define $ \Example2 file -> do + _pm <- getParsedModule file + let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" + return ([diag], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses Example2 $ HashSet.toList files + +mkDiag :: NormalizedFilePath + -> DiagnosticSource + -> DiagnosticSeverity + -> Range + -> T.Text + -> FileDiagnostic +mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- + +-- | Generate code actions. +codeAction + :: IdeState + -> PluginId + -> TextDocumentIdentifier + -> Range + -> CodeActionContext + -> IO (Either ResponseError (List CAResult)) +codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + let + title = "Add TODO2 Item" + tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + "-- TODO2 added by Example2 Plugin directly\n"] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + pure $ Right $ List + [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + +-- --------------------------------------------------------------------- + +codeLens + :: IdeState + -> PluginId + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath + _diag <- getDiagnostics ideState + _hDiag <- getHiddenDiagnostics ideState + let + title = "Add TODO2 Item via Code Lens" + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] + Nothing -> pure $ Right $ List [] + +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +addTodoCmd (AddTodoParams uri todoText) = do + let + pos = Position 5 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO2:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + +-- --------------------------------------------------------------------- + +foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) +foundHover (mbRange, contents) = + Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown + $ T.intercalate sectionSeparator contents) mbRange + + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> Action (Maybe a)) + -> Either ResponseError b + -> (a -> Either ResponseError b) + -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath path + logInfo (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runAction ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider +symbols _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example2_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 4 1) (Position 4 7) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider +completion _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example2 completion" + kind = Nothing + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index e0e535b74d..bd8e3f9ea7 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -7,7 +7,8 @@ module Ide.Plugin.Floskell ( - provider + descriptor + , provider ) where @@ -18,11 +19,28 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Floskell import Ide.Plugin.Formatter +import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = mempty + , pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginFormattingProvider = Just provider + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + -- | Format provider of Floskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index 127a654f54..10bf289c9d 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -7,9 +7,9 @@ module Ide.Plugin.Formatter ( - formatterPlugins - , FormattingType(..) - , FormattingProvider + formatting + , rangeFormatting + , noneProvider , responseError , extractRange , fullRange @@ -20,39 +20,24 @@ import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.Rules -import Development.IDE.LSP.Server -import Development.IDE.Plugin +import Development.IDE.Core.Shake +-- import Development.IDE.LSP.Server +-- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import Development.Shake hiding ( Diagnostic ) +-- import Development.Shake hiding ( Diagnostic ) +-- import Ide.Logger +import Ide.Types +import Development.IDE.Types.Logger import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages +-- import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config -formatterPlugins providers = Plugin rules (handlers (Map.fromList (("none",noneProvider):providers))) - --- --------------------------------------------------------------------- --- New style plugin - -rules :: Rules () -rules = mempty - -handlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config -handlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- - -formatting :: Map.Map T.Text (FormattingProvider IO) +formatting :: Map.Map PluginId (FormattingProvider IO) -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) formatting providers lf ideState @@ -61,7 +46,7 @@ formatting providers lf ideState -- --------------------------------------------------------------------- -rangeFormatting :: Map.Map T.Text (FormattingProvider IO) +rangeFormatting :: Map.Map PluginId (FormattingProvider IO) -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) rangeFormatting providers lf ideState @@ -70,46 +55,28 @@ rangeFormatting providers lf ideState -- --------------------------------------------------------------------- -doFormatting :: LSP.LspFuncs Config -> Map.Map T.Text (FormattingProvider IO) +doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) -> IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) doFormatting lf providers ideState ft uri params = do mc <- LSP.config lf let mf = maybe "none" formattingProvider mc - case Map.lookup mf providers of + case Map.lookup (PluginId mf) providers of Just provider -> case uriToFilePath uri of Just (toNormalizedFilePath -> fp) -> do (_, mb_contents) <- runAction ideState $ getFileContents fp case mb_contents of - Just contents -> provider ideState ft contents fp params + Just contents -> do + logDebug (ideLogger ideState) $ T.pack $ + "Formatter.doFormatting: contents=" ++ show contents -- AZ + provider ideState ft contents fp params Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]" -- --------------------------------------------------------------------- --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range - - --- | To format a whole document, the 'FormatText' @FormattingType@ can be used. --- It is required to pass in the whole Document Text for that to happen, an empty text --- and file uri, does not suffice. -type FormattingProvider m - = IdeState - -> FormattingType -- ^ How much to format - -> T.Text -- ^ Text to format - -> NormalizedFilePath -- ^ location of the file being formatted - -> FormattingOptions -- ^ Options for the formatter - -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting - --- --------------------------------------------------------------------- - noneProvider :: FormattingProvider IO noneProvider _ _ _ _ _ = return $ Right (List []) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index a27f5086bf..dcf8dcc692 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -7,34 +7,48 @@ module Ide.Plugin.Ormolu ( - provider + descriptor + , provider ) where -#if __GLASGOW_HASKELL__ >= 806 import Control.Exception -import Data.Char -import qualified Data.Text as T -import GHC -import Ormolu -import qualified DynFlags as D -import qualified EnumSet as S -import qualified HIE.Bios as BIOS -#endif - import Control.Monad +import Data.Char import Data.List import Data.Maybe +import qualified Data.Text as T import Development.IDE.Core.Rules --- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location +import qualified DynFlags as D +import qualified EnumSet as S +import GHC +import Ide.Types +import qualified HIE.Bios as BIOS import Ide.Plugin.Formatter import Language.Haskell.LSP.Types +import Ormolu import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = mempty + , pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginFormattingProvider = Just provider + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + provider :: FormattingProvider IO #if __GLASGOW_HASKELL__ >= 806 provider ideState typ contents fp _ = do diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs new file mode 100644 index 0000000000..f0a7afce15 --- /dev/null +++ b/src/Ide/Plugin/Pragmas.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides code actions to add missing pragmas (whenever GHC suggests to) +module Ide.Plugin.Pragmas + ( + descriptor + -- , commands -- TODO: get rid of this + ) where + +import Control.Lens hiding (List) +import Data.Aeson +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Ide.Plugin +import Ide.Types +import qualified GHC.Generics as Generics +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J +import Development.IDE.Types.Diagnostics as D +import Language.Haskell.LSP.Types + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = mempty + , pluginCommands = commands + , pluginCodeActionProvider = Just codeActionProvider + , pluginCodeLensProvider = Nothing + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + +commands :: [PluginCommand] +commands = [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd + ] + +-- --------------------------------------------------------------------- + +-- | Parameters for the addPragma PluginCommand. +data AddPragmaParams = AddPragmaParams + { file :: J.Uri -- ^ Uri of the file to add the pragma to + , pragma :: T.Text -- ^ Name of the Pragma to add + } + deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) + +-- | Add a Pragma to the given URI at the top of the file. +-- Pragma is added to the first line of the Uri. +-- It is assumed that the pragma name is a valid pragma, +-- thus, not validated. +-- addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit) +addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +addPragmaCmd (AddPragmaParams uri pragmaName) = do + let + pos = J.Position 0 0 + textEdits = J.List + [J.TextEdit (J.Range pos pos) + ("{-# LANGUAGE " <> pragmaName <> " #-}\n") + ] + res = J.WorkspaceEdit + (Just $ H.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + +-- --------------------------------------------------------------------- + +-- | Offer to add a missing Language Pragma to the top of a file. +-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. +codeActionProvider :: CodeActionProvider +codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do + cmds <- mapM mkCommand pragmas + -- cmds <- mapM mkCommand ("FooPragma":pragmas) + return $ Right $ List cmds + where + -- Filter diagnostics that are from ghcmod + ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags + -- Get all potential Pragmas for all diagnostics. + pragmas = concatMap (\d -> findPragma (d ^. J.message)) ghcDiags + mkCommand pragmaName = do + let + -- | Code Action for the given command. + codeAction :: J.Command -> J.CAResult + codeAction cmd = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing (Just cmd) + title = "Add \"" <> pragmaName <> "\"" + cmdParams = [toJSON (AddPragmaParams (docId ^. J.uri) pragmaName )] + cmd <- mkLspCommand plId "addPragma" title (Just cmdParams) + return $ codeAction cmd + +-- --------------------------------------------------------------------- + +-- | Find all Pragmas are an infix of the search term. +findPragma :: T.Text -> [T.Text] +findPragma str = concatMap check possiblePragmas + where + check p = [p | T.isInfixOf p str] + +-- --------------------------------------------------------------------- + +-- | Possible Pragma names. +-- Is non-exhaustive, and may be extended. +possiblePragmas :: [T.Text] +possiblePragmas = + [ + "ConstraintKinds" + , "DefaultSignatures" + , "DeriveAnyClass" + , "DeriveDataTypeable" + , "DeriveFoldable" + , "DeriveFunctor" + , "DeriveGeneric" + , "DeriveLift" + , "DeriveTraversable" + , "DerivingStrategies" + , "DerivingVia" + , "EmptyCase" + , "EmptyDataDecls" + , "EmptyDataDeriving" + , "FlexibleContexts" + , "FlexibleInstances" + , "GADTs" + , "GHCForeignImportPrim" + , "GeneralizedNewtypeDeriving" + , "IncoherentInstances" + , "InstanceSigs" + , "KindSignatures" + , "MultiParamTypeClasses" + , "MultiWayIf" + , "NamedFieldPuns" + , "NamedWildCards" + , "OverloadedStrings" + , "ParallelListComp" + , "PartialTypeSignatures" + , "PatternGuards" + , "PatternSignatures" + , "PatternSynonyms" + , "QuasiQuotes" + , "Rank2Types" + , "RankNTypes" + , "RecordPuns" + , "RecordWildCards" + , "RecursiveDo" + , "RelaxedPolyRec" + , "RoleAnnotations" + , "ScopedTypeVariables" + , "StandaloneDeriving" + , "StaticPointers" + , "TemplateHaskell" + , "TemplateHaskellQuotes" + , "TransformListComp" + , "TupleSections" + , "TypeApplications" + , "TypeFamilies" + , "TypeFamilyDependencies" + , "TypeInType" + , "TypeOperators" + , "TypeSynonymInstances" + , "UnboxedSums" + , "UndecidableInstances" + , "UndecidableSuperClasses" + , "ViewPatterns" + ] + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs new file mode 100644 index 0000000000..3c1339433c --- /dev/null +++ b/src/Ide/Types.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Types + ( + IdePlugins(..) + , PluginDescriptor(..) + , PluginCommand(..) + , PluginId(..) + , CommandId(..) + , DiagnosticProvider(..) + , DiagnosticProviderFunc(..) + , SymbolsProvider + , FormattingType(..) + , FormattingProvider + , HoverProvider + , CodeActionProvider + , CodeLensProvider + , ExecuteCommandProvider + , CompletionProvider + , WithSnippets(..) + ) where + +import Data.Aeson hiding (defaultOptions) +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String +import qualified Data.Text as T +import Development.IDE.Core.Rules +-- import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.Shake +-- import Development.Shake.Classes +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +newtype IdePlugins = IdePlugins + { ipMap :: Map.Map PluginId PluginDescriptor + } + +-- --------------------------------------------------------------------- + +data PluginDescriptor = + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand] + , pluginCodeActionProvider :: !(Maybe CodeActionProvider) + , pluginCodeLensProvider :: !(Maybe CodeLensProvider) + , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) + -- ^ TODO: diagnostics are generally provided via rules, + -- this is probably redundant. + , pluginHoverProvider :: !(Maybe HoverProvider) + , pluginSymbolsProvider :: !(Maybe SymbolsProvider) + , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) + , pluginCompletionProvider :: !(Maybe CompletionProvider) + } + +-- instance Show PluginCommand where +-- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" + +-- newtype CommandId = CommandId T.Text +-- deriving (Show, Read, Eq, Ord) +-- instance IsString CommandId where +-- fromString = CommandId . T.pack + +-- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => +-- PluginCommand { commandId :: CommandId +-- , commandDesc :: T.Text +-- , commandFunc :: a -> IO (Either ResponseError b) +-- } + +newtype CommandId = CommandId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString CommandId where + fromString = CommandId . T.pack + +data PluginCommand = forall a. (FromJSON a) => + PluginCommand { commandId :: CommandId + , commandDesc :: T.Text + , commandFunc :: a -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + } +-- --------------------------------------------------------------------- + +type CodeActionProvider = IdeState + -> PluginId + -> TextDocumentIdentifier + -> Range + -> CodeActionContext + -> IO (Either ResponseError (List CAResult)) + + +type CodeLensProvider = IdeState + -> PluginId + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) + +type DiagnosticProviderFuncSync + = DiagnosticTrigger -> Uri + -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) + +type DiagnosticProviderFuncAsync + = DiagnosticTrigger -> Uri + -> (Map.Map Uri (S.Set Diagnostic) -> IO ()) + -> IO (Either ResponseError ()) + +data DiagnosticProviderFunc + = DiagnosticProviderSync DiagnosticProviderFuncSync + | DiagnosticProviderAsync DiagnosticProviderFuncAsync + + +data DiagnosticProvider = DiagnosticProvider + { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? + , dpFunc :: DiagnosticProviderFunc + } + +data DiagnosticTrigger = DiagnosticOnOpen + | DiagnosticOnChange + | DiagnosticOnSave + deriving (Show,Ord,Eq) + +-- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) +type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) + +type SymbolsProvider = IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError [DocumentSymbol]) + +type ExecuteCommandProvider = IdeState + -> ExecuteCommandParams + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + +newtype WithSnippets = WithSnippets Bool + +type CompletionProvider = IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) + +-- --------------------------------------------------------------------- + +newtype PluginId = PluginId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString PluginId where + fromString = PluginId . T.pack + +-- --------------------------------------------------------------------- + + +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range + + +-- | To format a whole document, the 'FormatText' @FormattingType@ can be used. +-- It is required to pass in the whole Document Text for that to happen, an empty text +-- and file uri, does not suffice. +type FormattingProvider m + = IdeState + -> FormattingType -- ^ How much to format + -> T.Text -- ^ Text to format + -> NormalizedFilePath -- ^ location of the file being formatted + -> FormattingOptions -- ^ Options for the formatter + -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting + +-- --------------------------------------------------------------------- diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 9553fedf96..8a423908b4 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -40,6 +40,7 @@ extra-deps: - rope-utf16-splay-0.3.1.0 - shake-0.18.5 - syz-0.2.0.0 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - unix-compat-0.5.2 - unordered-containers-0.2.10.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 502876e4dc..09e70f6958 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -31,6 +31,7 @@ extra-deps: - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - semialign-1.1 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - topograph-1 diff --git a/stack.yaml b/stack.yaml index dc60f2eaaa..962025b4e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ extra-deps: - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - semialign-1.1 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - topograph-1 diff --git a/test-logs/README.md b/test-logs/README.md new file mode 100644 index 0000000000..ab5a8efcca --- /dev/null +++ b/test-logs/README.md @@ -0,0 +1 @@ +## When the tests run, the logs get put here. diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 077a3f4cfc..66db73c202 100644 --- a/test/functional/FormatSpec.hs +++ b/test/functional/FormatSpec.hs @@ -26,7 +26,7 @@ spec = do describe "format range" $ do it "works" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True) (Range (Position 2 0) (Position 4 10)) documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize2) it "works with custom tab size" $ do pendingWith "ormolu does not accept parameters" @@ -47,9 +47,24 @@ spec = do formatDoc doc (FormattingOptions 2 True) documentContents doc >>= liftIO . (`shouldBe` orig) - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True) (Range (Position 2 0) (Position 4 10)) documentContents doc >>= liftIO . (`shouldBe` orig) + -- --------------------------------- + + it "formatting is idempotent" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) + + formatDoc doc (FormattingOptions 2 True) + liftIO $ pendingWith "documentContents returns junk" + documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) + + -- --------------------------------- + it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" @@ -62,6 +77,7 @@ spec = do sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) formatDoc doc (FormattingOptions 2 True) + liftIO $ pendingWith "documentContents returns junk" documentContents doc >>= liftIO . (`shouldBe` formattedFloskellPostBrittany) -- sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) @@ -99,6 +115,8 @@ spec = do -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) -- "foo x y = do\n print x\n return 42\n"] + -- --------------------------------- + describe "ormolu" $ do let formatLspConfig provider = object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] @@ -114,9 +132,12 @@ spec = do GHC86 -> formatted _ -> liftIO $ docContent `shouldBe` unchangedOrmolu +-- --------------------------------------------------------------------- + formattedDocOrmolu :: T.Text formattedDocOrmolu = - "module Format where\n\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\n\ @@ -149,7 +170,8 @@ formattedDocTabSize5 = formattedRangeTabSize2 :: T.Text formattedRangeTabSize2 = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ @@ -157,11 +179,12 @@ formattedRangeTabSize2 = \bar s = do\n\ \ x <- return \"hello\"\n\ \ return \"asdf\"\n\ - \ \n" + \" formattedRangeTabSize5 :: T.Text formattedRangeTabSize5 = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ @@ -173,7 +196,8 @@ formattedRangeTabSize5 = formattedFloskell :: T.Text formattedFloskell = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -189,7 +213,8 @@ formattedFloskell = -- (duplicated last line) formattedFloskellPostBrittany :: T.Text formattedFloskellPostBrittany = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -199,12 +224,12 @@ formattedFloskellPostBrittany = \bar s = do\n\ \ x <- return \"hello\"\n\ \ return \"asdf\"\n\ - \ return \"asdf\"\n\ \" formattedBrittanyPostFloskell :: T.Text formattedBrittanyPostFloskell = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -217,7 +242,8 @@ formattedBrittanyPostFloskell = formattedOrmolu :: T.Text formattedOrmolu = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -230,7 +256,8 @@ formattedOrmolu = unchangedOrmolu :: T.Text unchangedOrmolu = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs new file mode 100644 index 0000000000..09a2d726c7 --- /dev/null +++ b/test/functional/PluginSpec.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module PluginSpec where + +import Control.Applicative.Combinators +import Control.Lens hiding (List) +-- import Control.Monad +import Control.Monad.IO.Class +-- import Data.Aeson +-- import Data.Default +-- import qualified Data.HashMap.Strict as HM +-- import Data.Maybe +import qualified Data.Text as T +-- import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +-- import qualified Language.Haskell.LSP.Types.Capabilities as C +import qualified Language.Haskell.LSP.Types.Lens as L +import Test.Hspec +import TestUtils + +#if __GLASGOW_HASKELL__ < 808 +-- import Data.Monoid ((<>)) +#endif + +-- --------------------------------------------------------------------- + +-- | Put a text marker on stdout in the client and the server log +mark :: String -> Session () +mark str = do + sendNotification (CustomClientMethod "$/testid") (T.pack str) + liftIO $ putStrLn str + +-- --------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "composes code actions" $ + it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do + + mark "provides 3.8 code actions" + + doc <- openDoc "Format.hs" "haskell" + diags@(diag1:_) <- waitForDiagnosticsSource "typecheck" + + -- liftIO $ putStrLn $ "diags = " ++ show diags -- AZ + liftIO $ do + length diags `shouldBe` 5 + diag1 ^. L.range `shouldBe` Range (Position 2 9) (Position 2 12) + diag1 ^. L.severity `shouldBe` Just DsError + diag1 ^. L.code `shouldBe` Nothing + -- diag1 ^. L.source `shouldBe` Just "example2" + + diag1 ^. L.source `shouldBe` Just "typecheck" + -- diag2 ^. L.source `shouldBe` Just "example" + + _cas@(CACodeAction ca:_) <- getAllCodeActions doc + -- liftIO $ length cas `shouldBe` 2 + + -- liftIO $ putStrLn $ "cas = " ++ show cas -- AZ + + liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] + + -- mark "A" -- AZ + executeCodeAction ca + -- mark "B" -- AZ + + -- _ <- skipMany (message @RegisterCapabilityRequest) + -- liftIO $ putStrLn $ "B2" -- AZ + + -- _diags2 <- waitForDiagnosticsSource "typecheck" + -- liftIO $ putStrLn $ "diags2 = " ++ show _diags2 -- AZ + + -- contents <- getDocumentEdit doc + -- mark "C" -- AZ + -- liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + + -- noDiagnostics + return () + + describe "symbol providers" $ + it "combines symbol providers" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do + + doc <- openDoc "Format.hs" "haskell" + + _ <- waitForDiagnostics + + id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse + liftIO $ symbolsRsp ^. L.id `shouldBe` responseId id2 + + liftIO $ symbolsRsp ^. L.result `shouldBe` + Just (DSDocumentSymbols + (List [DocumentSymbol + "Example_symbol_name" + Nothing + SkVariable + Nothing + (Range {_start = Position {_line = 2, _character = 0} + , _end = Position {_line = 2, _character = 5}}) + (Range {_start = Position {_line = 2, _character = 0} + , _end = Position {_line = 2, _character = 5}}) + Nothing + ,DocumentSymbol "Example2_symbol_name" + Nothing + SkVariable + Nothing + (Range {_start = Position {_line = 4, _character = 1} + , _end = Position {_line = 4, _character = 7}}) + (Range {_start = Position {_line = 4, _character = 1} + , _end = Position {_line = 4, _character = 7}}) + Nothing])) + + return () diff --git a/test/testdata/BrittanyCRLF.hs b/test/testdata/BrittanyCRLF.hs index 2ed3293b3d..1bac0322e8 100644 --- a/test/testdata/BrittanyCRLF.hs +++ b/test/testdata/BrittanyCRLF.hs @@ -1,3 +1,5 @@ -foo :: Int -> String-> IO () -foo x y = do print x - return 42 \ No newline at end of file +module BrittanyCRLF where + +foo :: Int -> String-> IO () +foo x y = do print x + return () diff --git a/test/testdata/BrittanyLF.hs b/test/testdata/BrittanyLF.hs index 4662d9b5a8..3f54b9e4f2 100644 --- a/test/testdata/BrittanyLF.hs +++ b/test/testdata/BrittanyLF.hs @@ -1,3 +1,5 @@ +module BrittanyLF where + foo :: Int -> String-> IO () foo x y = do print x - return 42 \ No newline at end of file + return () diff --git a/test/testdata/Format.hs b/test/testdata/Format.hs index 76e40c9816..b3aff40f91 100644 --- a/test/testdata/Format.hs +++ b/test/testdata/Format.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 @@ -6,4 +7,3 @@ bar :: String -> IO String bar s = do x <- return "hello" return "asdf" - diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal index c191bbd1f1..04dc2a7073 100644 --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -3,80 +3,88 @@ version: 0.1.0.0 cabal-version: >=2.0 build-type: Simple -executable applyrefact +library build-depends: base - main-is: ApplyRefact.hs - default-language: Haskell2010 - -executable applyrefact2 - build-depends: base - main-is: ApplyRefact2.hs - default-language: Haskell2010 - -executable codeactionrename - build-depends: base - main-is: CodeActionRename.hs - default-language: Haskell2010 - -executable hover - build-depends: base - main-is: Hover.hs - default-language: Haskell2010 - -executable symbols - build-depends: base - main-is: Symbols.hs - default-language: Haskell2010 - - -executable applyrefact2 - build-depends: base - main-is: ApplyRefact2.hs - default-language: Haskell2010 - -executable hlintpragma - build-depends: base - main-is: HlintPragma.hs - default-language: Haskell2010 - -executable harecase - build-depends: base - main-is: HaReCase.hs - default-language: Haskell2010 - -executable haredemote - build-depends: base - main-is: HaReDemote.hs - default-language: Haskell2010 - -executable haremovedef - build-depends: base - main-is: HaReMoveDef.hs - default-language: Haskell2010 - -executable harerename - build-depends: base - main-is: HaReRename.hs - default-language: Haskell2010 - -executable haregenapplicative - build-depends: base - , parsec - main-is: HaReGA1.hs - default-language: Haskell2010 - -executable functests - build-depends: base - main-is: FuncTest.hs - default-language: Haskell2010 - -executable evens - build-depends: base - main-is: Evens.hs - hs-source-dirs: liquid - default-language: Haskell2010 - -executable filewithwarning - build-depends: base - main-is: FileWithWarning.hs default-language: Haskell2010 + exposed-modules: + BrittanyCRLF + BrittanyLF + Format + +-- executable applyrefact +-- build-depends: base +-- main-is: ApplyRefact.hs +-- default-language: Haskell2010 + +-- executable applyrefact2 +-- build-depends: base +-- main-is: ApplyRefact2.hs +-- default-language: Haskell2010 + +-- executable codeactionrename +-- build-depends: base +-- main-is: CodeActionRename.hs +-- default-language: Haskell2010 + +-- executable hover +-- build-depends: base +-- main-is: Hover.hs +-- default-language: Haskell2010 + +-- executable symbols +-- build-depends: base +-- main-is: Symbols.hs +-- default-language: Haskell2010 + + +-- executable applyrefact2 +-- build-depends: base +-- main-is: ApplyRefact2.hs +-- default-language: Haskell2010 + +-- executable hlintpragma +-- build-depends: base +-- main-is: HlintPragma.hs +-- default-language: Haskell2010 + +-- executable harecase +-- build-depends: base +-- main-is: HaReCase.hs +-- default-language: Haskell2010 + +-- executable haredemote +-- build-depends: base +-- main-is: HaReDemote.hs +-- default-language: Haskell2010 + +-- executable haremovedef +-- build-depends: base +-- main-is: HaReMoveDef.hs +-- default-language: Haskell2010 + +-- executable harerename +-- build-depends: base +-- main-is: HaReRename.hs +-- default-language: Haskell2010 + +-- executable haregenapplicative +-- build-depends: base +-- , parsec +-- main-is: HaReGA1.hs +-- default-language: Haskell2010 + +-- executable functests +-- build-depends: base +-- main-is: FuncTest.hs +-- default-language: Haskell2010 + +-- executable evens +-- build-depends: base +-- main-is: Evens.hs +-- hs-source-dirs: liquid +-- default-language: Haskell2010 + +-- executable filewithwarning +-- build-depends: base +-- main-is: FileWithWarning.hs +-- default-language: Haskell2010 diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 15f6a78cd3..7cb70cc1e4 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -138,6 +138,7 @@ setupDirectFilesIn :: FilePath -> IO () setupDirectFilesIn f = writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents + -- --------------------------------------------------------------------- files :: [FilePath] @@ -205,7 +206,9 @@ logFilePath = "hie-" ++ stackYaml ++ ".log" -- stack just puts all project executables on PATH. hieCommand :: String -- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath -hieCommand = "haskell-language-server --lsp" +-- hieCommand = "haskell-language-server --lsp" +-- hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath +hieCommand = "haskell-language-server --lsp -d -l test-logs/" ++ logFilePath hieCommandVomit :: String hieCommandVomit = hieCommand ++ " --vomit" @@ -245,38 +248,38 @@ testdataHieYamlCradleStackContents = unlines [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" , "cradle:" , " stack:" - , " - path: \"ApplyRefact.hs\"" - , " component: \"testdata:exe:applyrefact\"" - , " - path: \"ApplyRefact2.hs\"" - , " component: \"testdata:exe:applyrefact2\"" - , " - path: \"CodeActionRename.hs\"" - , " component: \"testdata:exe:codeactionrename\"" - , " - path: \"Hover.hs\"" - , " component: \"testdata:exe:hover\"" - , " - path: \"Symbols.hs\"" - , " component: \"testdata:exe:symbols\"" - , " - path: \"ApplyRefact2.hs\"" - , " component: \"testdata:exe:applyrefact2\"" - , " - path: \"HlintPragma.hs\"" - , " component: \"testdata:exe:hlintpragma\"" - , " - path: \"HaReCase.hs\"" - , " component: \"testdata:exe:harecase\"" - , " - path: \"HaReDemote.hs\"" - , " component: \"testdata:exe:haredemote\"" - , " - path: \"HaReMoveDef.hs\"" - , " component: \"testdata:exe:haremovedef\"" - , " - path: \"HaReRename.hs\"" - , " component: \"testdata:exe:harerename\"" - , " - path: \"HaReGA1.hs\"" - , " component: \"testdata:exe:haregenapplicative\"" - , " - path: \"FuncTest.hs\"" - , " component: \"testdata:exe:functests\"" - , " - path: \"liquid/Evens.hs\"" - , " component: \"testdata:exe:evens\"" - , " - path: \"FileWithWarning.hs\"" - , " component: \"testdata:exe:filewithwarning\"" - , " - path: ." - , " component: \"testdata:exe:filewithwarning\"" + -- , " - path: \"ApplyRefact.hs\"" + -- , " component: \"testdata:exe:applyrefact\"" + -- , " - path: \"ApplyRefact2.hs\"" + -- , " component: \"testdata:exe:applyrefact2\"" + -- , " - path: \"CodeActionRename.hs\"" + -- , " component: \"testdata:exe:codeactionrename\"" + -- , " - path: \"Hover.hs\"" + -- , " component: \"testdata:exe:hover\"" + -- , " - path: \"Symbols.hs\"" + -- , " component: \"testdata:exe:symbols\"" + -- , " - path: \"ApplyRefact2.hs\"" + -- , " component: \"testdata:exe:applyrefact2\"" + -- , " - path: \"HlintPragma.hs\"" + -- , " component: \"testdata:exe:hlintpragma\"" + -- , " - path: \"HaReCase.hs\"" + -- , " component: \"testdata:exe:harecase\"" + -- , " - path: \"HaReDemote.hs\"" + -- , " component: \"testdata:exe:haredemote\"" + -- , " - path: \"HaReMoveDef.hs\"" + -- , " component: \"testdata:exe:haremovedef\"" + -- , " - path: \"HaReRename.hs\"" + -- , " component: \"testdata:exe:harerename\"" + -- , " - path: \"HaReGA1.hs\"" + -- , " component: \"testdata:exe:haregenapplicative\"" + -- , " - path: \"FuncTest.hs\"" + -- , " component: \"testdata:exe:functests\"" + -- , " - path: \"liquid/Evens.hs\"" + -- , " component: \"testdata:exe:evens\"" + -- , " - path: \"FileWithWarning.hs\"" + -- , " component: \"testdata:exe:filewithwarning\"" + -- , " - path: ." + -- , " component: \"testdata:exe:filewithwarning\"" ]