diff --git a/.gitmodules b/.gitmodules index f7d6551110..7faeadd5ea 100644 --- a/.gitmodules +++ b/.gitmodules @@ -10,5 +10,5 @@ # rm -rf path_to_submodule [submodule "ghcide"] path = ghcide - url = https://github.com/digital-asset/ghcide.git - # url = https://github.com/alanz/ghcide.git + # url = https://github.com/digital-asset/ghcide.git + url = https://github.com/alanz/ghcide.git diff --git a/cabal.project b/cabal.project index 92e6aaa60b..795fac89f9 100644 --- a/cabal.project +++ b/cabal.project @@ -8,6 +8,8 @@ source-repository-package tag: a18bbb2af92e9b4337e7f930cb80754f2408bcfd tests: true +documentation: false +-- documentation: true package haskell-language-server test-show-details: direct @@ -16,4 +18,4 @@ package ghcide write-ghc-environment-files: never -index-state: 2020-03-03T21:14:55Z +index-state: 2020-03-24T21:15:10Z diff --git a/exe/Main.hs b/exe/Main.hs index 439a1be19b..02d865b672 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,5 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} -- To get precise GHC version +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,13 +17,20 @@ import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import Data.ByteString.Base16 (encode) +import qualified Data.ByteString.Char8 as B import Data.Default +import Data.Either +import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet +import Data.IORef 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.Time.Clock (UTCTime) -- import Data.Version -- import Development.GitRev import Development.IDE.Core.Debouncer @@ -39,16 +48,29 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action, Rules, action) -import HIE.Bios +import Development.Shake (Action, action) +import DynFlags (gopt_set, gopt_unset, + updOptLevel) +import DynFlags (PackageFlag(..), PackageArg(..)) +import GHC hiding (def) +import GHC.Check (runTimeVersion, compileTimeVersionFromLibdir) +-- import GhcMonad +import HIE.Bios.Cradle +import HIE.Bios.Environment (addCmdOpts) +import HIE.Bios.Types +import HscTypes (HscEnv(..), ic_dflags) 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 RuleTypes -import Rules +import Linker (initDynLinker) +import Module +import NameCache +import Packages +-- import Paths_ghcide +import System.Directory import qualified System.Directory.Extra as IO -- import System.Environment import System.Exit @@ -95,7 +117,7 @@ idePlugins pid includeExamples -- , hsimportDescriptor "hsimport" -- , liquidDescriptor "liquid" -- , packageDescriptor "package" - GhcIde.descriptor "ghc" + GhcIde.descriptor "ghcide" , Pragmas.descriptor "pragmas" , Floskell.descriptor "floskell" -- , genericDescriptor "generic" @@ -110,18 +132,10 @@ idePlugins pid includeExamples -- --------------------------------------------------------------------- --- 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) --} +-- -- Set the GHC libdir to the nix libdir if it's present. +-- getLibdir :: IO FilePath +-- getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" main :: IO () main = do @@ -148,8 +162,8 @@ main = do pid <- getPid let - -- (ps, commandIds) = idePlugins pid argsExamplePlugin - (ps, commandIds) = idePlugins pid True + (ps, commandIds) = idePlugins pid argsExamplePlugin + -- (ps, commandIds) = idePlugins pid True plugins = Completions.plugin <> CodeAction.plugin <> Plugin mempty HoverDefinition.setHandlersDefinition <> ps @@ -168,9 +182,11 @@ main = do { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling , optTesting = argsTesting + , optInterfaceLoadingDiagnostics = argsTesting + , optThreads = 1 } debouncer <- newAsyncDebouncer - initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) + initialise caps (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 @@ -191,44 +207,18 @@ main = do let ucradles = nubOrd cradles let n = length ucradles putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] - sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do - let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x - putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg - cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x - when (isNothing x) $ print cradle - putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session" - opts <- getComponentOptions cradle - createSession opts - - putStrLn "\nStep 5/6: Initializing the IDE" + putStrLn "\nStep 3/6: Initializing the IDE" vfs <- makeVFSHandle - let cradlesToSessions = Map.fromList $ zip ucradles sessions - let filesToCradles = Map.fromList $ zip files cradles - let grab file = fromMaybe (head sessions) $ do - cradle <- Map.lookup file filesToCradles - Map.lookup cradle cradlesToSessions - - let options = - (defaultIdeOptions $ return $ return . grab) - { optShakeProfiling = argsShakeProfiling } - 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 - results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files - let (worked, failed) = partition fst $ zip (map isJust results) files - when (failed /= []) $ - putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - - let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" - putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)" - - unless (null failed) exitFailure - -cradleRules :: Rules () -cradleRules = do - loadGhcSession - cradleToSession + + debouncer <- newAsyncDebouncer + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSession dir) vfs + + putStrLn "\nStep 4/6: Type checking the files" + setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files + _ <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files) +-- results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "src/Development/IDE/Core/Rules.hs" +-- results <- runActionSync ide $ use TypeCheck $ toNormalizedFilePath' "exe/Main.hs" + return () expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do @@ -251,12 +241,58 @@ kick = do -- | Print an LSP event. showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return () -showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = +showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e + +cradleToSessionOpts :: Cradle a -> FilePath -> IO ComponentOptions +cradleToSessionOpts cradle file = do + let showLine s = putStrLn ("> " ++ s) + cradleRes <- runCradle (cradleOptsProg cradle) showLine file + 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" + pure opts + +emptyHscEnv :: IO HscEnv +emptyHscEnv = do + libdir <- getLibdir + env <- runGhc (Just libdir) getSession + initDynLinker env + pure env + +-- Convert a target to a list of potential absolute paths. +-- A TargetModule can be anywhere listed by the supplied include +-- directories +-- A target file is a relative path but with a specific prefix so just need +-- to canonicalise it. +targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath] +targetToFile is (TargetModule mod) = do + let fps = [i (moduleNameSlashes mod) -<.> ext | ext <- exts, i <- is ] + exts = ["hs", "hs-boot", "lhs"] + mapM (fmap toNormalizedFilePath' . canonicalizePath) fps +targetToFile _ (TargetFile f _) = do + f' <- canonicalizePath f + return [(toNormalizedFilePath' f')] + +setNameCache :: IORef NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + +-- This is the key function which implements multi-component support. All +-- components mapping to the same hie,yaml file are mapped to the same +-- HscEnv which is updated as new components are discovered. loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq) loadSession dir = liftIO $ do + -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file + hscEnvs <- newVar Map.empty + -- Mapping from a filepath to HscEnv + fileToFlags <- newVar Map.empty + + -- This caches the mapping from Mod.hs -> hie.yaml cradleLoc <- memoIO $ \v -> do res <- findCradle v -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path @@ -264,13 +300,180 @@ loadSession dir = liftIO $ do -- e.g. see https://github.com/digital-asset/ghcide/issues/126 res' <- traverse IO.makeAbsolute res return $ normalise <$> res' - 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) + -- Create a new HscEnv from a hieYaml root and a set of options + -- If the hieYaml file already has an HscEnv, the new component is + -- combined with the components in the old HscEnv into a new HscEnv + -- which contains both. + packageSetup <- return $ \(hieYaml, cfp, opts) -> do + -- Parse DynFlags for the newly discovered component + hscEnv <- emptyHscEnv + (df, targets) <- evalGhcEnv hscEnv $ do + setOptions opts (hsc_dflags hscEnv) + dep_info <- getDependencyInfo (componentDependencies opts) + -- Now lookup to see whether we are combining with an exisiting HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = (thisInstalledUnitId df, df, targets, cfp, dep_info) : maybe [] snd oldDeps + -- Get all the unit-ids for things in this component + inplace = map (\(a, _, _, _, _) -> a) new_deps + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + rearrange (uid, (df, uids), ts, cfp, di) = (uid, (df, uids, ts, cfp, di)) + do_one (uid,df, ts, cfp, di) = rearrange (uid, removeInplacePackages inplace df, ts, cfp, di) + -- All deps, but without any packages which are also loaded + -- into memory + new_deps' = map do_one new_deps + -- Make a new HscEnv, we have to recompile everything from + -- scratch again (for now) + -- It's important to keep the same NameCache though for reasons + -- that I do not fully understand + print ("Making new HscEnv" ++ (show inplace)) + hscEnv <- case oldDeps of + Nothing -> emptyHscEnv + Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv + newHscEnv <- + -- Add the options for the current component to the HscEnv + evalGhcEnv hscEnv $ do + _ <- setSessionDynFlags df + getSession + -- Modify the map so the hieYaml now maps to the newly created + -- HscEnv + -- Returns + -- * the new HscEnv so it can be used to modify the + -- FilePath -> HscEnv map + -- * The information for the new component which caused this cache miss + -- * The modified information (without -inplace flags) for + -- existing packages + pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) + + + session <- return $ \(hieYaml, cfp, opts) -> do + (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts) + -- TODO Handle the case where there is no hie.yaml + -- Make a map from unit-id to DynFlags, this is used when trying to + -- resolve imports. + let uids = map (\(iuid, (df, _uis, _targets, _cfp, _di)) -> (iuid, df)) (new : old_deps) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- + -- Then look at the targets for each component and create a map + -- from FilePath to the HscEnv + let new_cache (_iuid, (df, _uis, targets, cfp, di)) = do + let hscEnv' = hscEnv { hsc_dflags = df + , hsc_IC = (hsc_IC hscEnv) { ic_dflags = df } } + + versionMismatch <- evalGhcEnv hscEnv' checkGhcVersion + henv <- case versionMismatch of + Just mismatch -> return mismatch + Nothing -> newHscEnvEq hscEnv' uids + let res = (henv, di) + print res + + let is = importPaths df + ctargets <- concatMapM (targetToFile is . targetId) targets + -- A special target for the file which caused this wonderful + -- component to be created. + let special_target = (cfp, res) + --pprTraceM "TARGETS" (ppr (map (text . show) ctargets)) + let xs = map (,res) ctargets + return (special_target:xs, res) + + -- New HscEnv for the component in question + (cs, res) <- new_cache new + -- Modified cache targets for everything else in the hie.yaml file + -- which now uses the same EPS and so on + cached_targets <- concatMapM (fmap fst . new_cache) old_deps + modifyVar_ fileToFlags $ \var -> do + pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var + + return res + + lock <- newLock + cradle_lock <- newLock + + -- This caches the mapping from hie.yaml + Mod.hs -> [String] + sessionOpts <- return $ \(hieYaml, file) -> do + + + fm <- readVar fileToFlags + let mv = Map.lookup hieYaml fm + let v = fromMaybe HM.empty mv + cfp <- liftIO $ canonicalizePath file + case HM.lookup (toNormalizedFilePath' cfp) v of + Just (_, old_di) -> do + deps_ok <- checkDependencyInfo old_di + unless deps_ok $ do + modifyVar_ fileToFlags (const (return Map.empty)) + -- Keep the same name cache + modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) + Nothing -> return () + -- We sort so exact matches come first. + case HM.lookup (toNormalizedFilePath' cfp) v of + Just opts -> do + --putStrLn $ "Cached component of " <> show file + pure (fst opts) + Nothing-> do + finished_barrier <- newBarrier + -- fork a new thread here which won't be killed by shake + -- throwing an async exception + void $ forkIO $ withLock cradle_lock $ do + putStrLn $ "Shelling out to cabal " <> show file + cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + opts <- cradleToSessionOpts cradle cfp + print opts + res <- fst <$> session (hieYaml, toNormalizedFilePath' cfp, opts) + signalBarrier finished_barrier res + waitBarrier finished_barrier + return $ \file -> liftIO $ mask_ $ withLock lock $ do + hieYaml <- cradleLoc file + sessionOpts (hieYaml, file) + +checkDependencyInfo :: Map.Map FilePath (Maybe UTCTime) -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + + + +getDependencyInfo :: [FilePath] -> IO (Map.Map FilePath (Maybe UTCTime)) +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + do_one fp = do + exists <- IO.doesFileExist fp + if exists + then do + mtime <- getModificationTime fp + return (fp, Just mtime) + else return (fp, Nothing) + +-- This function removes all the -package flags which refer to packages we +-- are going to deal with ourselves. For example, if a executable depends +-- on a library component, then this function will remove the library flag +-- from the package flags for the executable +-- +-- There are several places in GHC (for example the call to hptInstances in +-- tcRnImports) which assume that all modules in the HPT have the same unit +-- ID. Therefore we create a fake one and give them all the same unit id. +removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) +removeInplacePackages us df = (df { packageFlags = ps + , thisInstalledUnitId = fake_uid }, uids) + where + (uids, ps) = partitionEithers (map go (packageFlags df)) + fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") + go p@(ExposePackage _ (UnitIdArg u) _) = if (toInstalledUnitId u `elem` us) then Left (toInstalledUnitId u) else Right p + go p = Right p -- | Memoize an IO function, with the characteristics: -- @@ -288,3 +491,68 @@ memoIO op = do res <- onceFork $ op k return (Map.insert k res mp, res) Just res -> return (mp, res) + +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) +setOptions (ComponentOptions theOpts _) dflags = do + cacheDir <- liftIO $ getCacheDir theOpts + (dflags', targets) <- addCmdOpts theOpts dflags + let dflags'' = + -- 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' + -- initPackages parses the -package flags and + -- sets up the visibility for each component. + (final_df, _) <- liftIO $ initPackages dflags'' +-- let df'' = gopt_unset df' Opt_WarnIsError + return (final_df, targets) + + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +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) + +-- Prefix for the cache path +cacheDir :: String +cacheDir = "ghcide" + +compileTimeGhcVersion :: Version +compileTimeGhcVersion = $$(compileTimeVersionFromLibdir getLibdir) + +checkGhcVersion :: Ghc (Maybe HscEnvEq) +checkGhcVersion = do + v <- runTimeVersion + return $ if v == Just compileTimeGhcVersion + then Nothing + else Just GhcVersionMismatch {compileTime = compileTimeGhcVersion, runTime = v} diff --git a/exe/RuleTypes.hs b/exe/RuleTypes.hs deleted file mode 100644 index 8520eaa44a..0000000000 --- a/exe/RuleTypes.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 deleted file mode 100644 index 00b6e178ca..0000000000 --- a/exe/Rules.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# 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/ghcide b/ghcide index 209be0b162..74311d255c 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 209be0b162bd80f9b0f62c5c1e93a6ed65b89b61 +Subproject commit 74311d255cc4a804de6ec69e6db4c13851c108f1 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 97b7ecd69a..23731e1850 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -27,7 +27,6 @@ source-repository head library exposed-modules: - Ide.Compat Ide.Cradle Ide.Logger Ide.Plugin @@ -63,7 +62,7 @@ library , ghcide >= 0.1 , gitrev , hashable - , haskell-lsp == 0.20.* + , haskell-lsp == 0.21.* , hie-bios >= 0.4 , hslogger , lens @@ -97,8 +96,6 @@ executable haskell-language-server other-modules: Arguments Paths_haskell_language_server - Rules - RuleTypes autogen-modules: Paths_haskell_language_server ghc-options: @@ -125,6 +122,7 @@ executable haskell-language-server , containers , data-default , deepseq + , directory , extra , filepath -------------------------------------------------------------- @@ -135,6 +133,7 @@ executable haskell-language-server -- which works for now. , ghc -------------------------------------------------------------- + , ghc-check , ghc-paths , ghcide , gitrev @@ -146,6 +145,7 @@ executable haskell-language-server , optparse-applicative , shake >= 0.17.5 , text + , time , unordered-containers default-language: Haskell2010 diff --git a/src/Ide/Compat.hs b/src/Ide/Compat.hs deleted file mode 100644 index f46ffa3f56..0000000000 --- a/src/Ide/Compat.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# 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/Plugin.hs b/src/Ide/Plugin.hs index 2f1a36498f..10ce65edbd 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -35,7 +35,6 @@ 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 @@ -115,7 +114,7 @@ makeCodeAction :: [(PluginId, CodeActionProvider)] 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 + r <- mapM (\(pid,provider) -> provider lf ideState pid docId range context) cas let actions = filter wasRequested . concat $ map unL $ rights r res <- send caps actions return $ Right res @@ -171,11 +170,11 @@ makeCodeLens :: [(PluginId, CodeLensProvider)] -> IdeState -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -makeCodeLens cas _lf ideState params = do +makeCodeLens cas lf ideState params = do logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ let makeLens (pid, provider) = do - r <- provider ideState pid params + r <- provider lf ideState pid params return (pid, r) breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) @@ -206,7 +205,7 @@ executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ -- -> ExecuteCommandParams -- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider -makeExecuteCommands ecs _lf _params = do +makeExecuteCommands ecs lf ide = do let pluginMap = Map.fromList ecs parseCmdId :: T.Text -> Maybe (PluginId, CommandId) @@ -251,7 +250,7 @@ makeExecuteCommands ecs _lf _params = do -- "Invalid fallbackCodeAction params" -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand pluginMap plugin cmd cmdParams + Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams -- Couldn't parse the command identifier _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) @@ -334,20 +333,33 @@ makeExecuteCommands ecs _lf _params = do -- | 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, +runPluginCommand :: Map.Map PluginId [PluginCommand] + -> LSP.LspFuncs Config + -> IdeState + -> PluginId + -> CommandId + -> J.Value + -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -runPluginCommand m p@(PluginId p') com@(CommandId com') arg = +runPluginCommand m lf ide p@(PluginId p') com@(CommandId com') arg = case Map.lookup p m of Nothing -> return (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) Just xs -> case List.find ((com ==) . commandId) xs of Nothing -> return (Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) + 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 + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' + <> ": " <> T.pack err + <> "\narg = " <> T.pack (show arg)) Nothing, Nothing) + J.Success a -> f lf ide a + +-- lsp-request: error while parsing args for typesignature.add in plugin ghcide: +-- When parsing the record ExecuteCommandParams of type +-- Language.Haskell.LSP.Types.DataTypesJSON.ExecuteCommandParams the key command +-- was not present. -- ----------------------------------------------------------- @@ -362,9 +374,6 @@ 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 @@ -439,7 +448,7 @@ makeSymbols sps lf ideState params si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent in [si] <> children' - mhs <- mapM (\(_,p) -> p ideState params) sps + mhs <- mapM (\(_,p) -> p lf ideState params) sps case rights mhs of [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs hs -> return $ Right $ convertSymbols $ concat hs diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 0ea345cef3..ddf5747989 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -99,6 +99,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) , _source = Just diagSource , _message = msg , _code = Nothing + , _tags = Nothing , _relatedInformation = Nothing } @@ -107,14 +108,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | 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 +codeAction :: CodeActionProvider +codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO Item 1" tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) @@ -125,12 +120,8 @@ codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_di -- --------------------------------------------------------------------- -codeLens - :: IdeState - -> PluginId - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens :: CodeLensProvider +codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do @@ -156,9 +147,8 @@ data AddTodoParams = AddTodoParams } deriving (Show, Eq, Generic, ToJSON, FromJSON) -addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -addTodoCmd (AddTodoParams uri todoText) = do +addTodoCmd :: CommandFunction AddTodoParams +addTodoCmd _lf _ide (AddTodoParams uri todoText) = do let pos = Position 3 0 textEdits = List @@ -205,7 +195,7 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- symbols :: SymbolsProvider -symbols _ide (DocumentSymbolParams _doc _mt) +symbols _lf _ide (DocumentSymbolParams _doc _mt) = pure $ Right [r] where r = DocumentSymbol name detail kind deprecation range selR chList @@ -223,12 +213,13 @@ completion :: CompletionProvider completion _ide (CompletionParams _doc _pos _mctxt _mt) = pure $ Right $ Completions $ List [r] where - r = CompletionItem label kind detail documentation deprecated preselect + r = CompletionItem label kind tags detail documentation deprecated preselect sortText filterText insertText insertTextFormat textEdit additionalTextEdits commitCharacters command xd label = "Example completion" kind = Nothing + tags = List [] detail = Nothing documentation = Nothing deprecated = Nothing diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 60f8d54d64..a6f56cbfc0 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -99,6 +99,7 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) , _source = Just diagSource , _message = msg , _code = Nothing + , _tags = Nothing , _relatedInformation = Nothing } @@ -107,14 +108,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- --------------------------------------------------------------------- -- | 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 +codeAction :: CodeActionProvider +codeAction _lf _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO2 Item" tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) @@ -125,12 +120,8 @@ codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_di -- --------------------------------------------------------------------- -codeLens - :: IdeState - -> PluginId - -> CodeLensParams - -> IO (Either ResponseError (List CodeLens)) -codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens :: CodeLensProvider +codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do @@ -153,9 +144,8 @@ data AddTodoParams = AddTodoParams } deriving (Show, Eq, Generic, ToJSON, FromJSON) -addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, - Maybe (ServerMethod, ApplyWorkspaceEditParams)) -addTodoCmd (AddTodoParams uri todoText) = do +addTodoCmd :: CommandFunction AddTodoParams +addTodoCmd _lf _ide (AddTodoParams uri todoText) = do let pos = Position 5 0 textEdits = List @@ -202,7 +192,7 @@ logAndRunRequest label getResults ide pos path = do -- --------------------------------------------------------------------- symbols :: SymbolsProvider -symbols _ide (DocumentSymbolParams _doc _mt) +symbols _lf _ide (DocumentSymbolParams _doc _mt) = pure $ Right [r] where r = DocumentSymbol name detail kind deprecation range selR chList @@ -220,12 +210,13 @@ completion :: CompletionProvider completion _ide (CompletionParams _doc _pos _mctxt _mt) = pure $ Right $ Completions $ List [r] where - r = CompletionItem label kind detail documentation deprecated preselect + r = CompletionItem label kind tags detail documentation deprecated preselect sortText filterText insertText insertTextFormat textEdit additionalTextEdits commitCharacters command xd label = "Example2 completion" kind = Nothing + tags = List [] detail = Nothing documentation = Nothing deprecated = Nothing diff --git a/src/Ide/Plugin/GhcIde.hs b/src/Ide/Plugin/GhcIde.hs index 16826956d7..063e47913d 100644 --- a/src/Ide/Plugin/GhcIde.hs +++ b/src/Ide/Plugin/GhcIde.hs @@ -1,13 +1,20 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.GhcIde ( descriptor ) where +import Data.Aeson +import Development.IDE.Core.Service +import Development.IDE.LSP.HoverDefinition +import Development.IDE.LSP.Outline +import Development.IDE.Plugin.CodeAction import Development.IDE.Types.Logger +import Ide.Plugin import Ide.Types -import Development.IDE.LSP.HoverDefinition -import Development.IDE.Core.Shake +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- @@ -15,12 +22,12 @@ descriptor :: PluginId -> PluginDescriptor descriptor plId = PluginDescriptor { pluginId = plId , pluginRules = mempty - , pluginCommands = [] - , pluginCodeActionProvider = Nothing - , pluginCodeLensProvider = Nothing + , pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature] + , pluginCodeActionProvider = Just codeAction' + , pluginCodeLensProvider = Just codeLens' , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Just hover' - , pluginSymbolsProvider = Nothing + , pluginSymbolsProvider = Just symbolsProvider , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } @@ -33,3 +40,30 @@ hover' ideState params = do hover ideState params -- --------------------------------------------------------------------- + +commandAddSignature :: CommandFunction WorkspaceEdit +commandAddSignature lf ide params + = executeAddSignatureCommand lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing) + +-- --------------------------------------------------------------------- + +codeAction' :: CodeActionProvider +codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context + +-- --------------------------------------------------------------------- + +codeLens' :: CodeLensProvider +codeLens' lf ide _ params = codeLens lf ide params + +-- --------------------------------------------------------------------- + +symbolsProvider :: SymbolsProvider +symbolsProvider ls ide params = do + ds <- moduleOutline ls ide params + case ds of + Right (DSDocumentSymbols (List ls)) -> return $ Right ls + Right (DSSymbolInformation (List _si)) -> + return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated" + Left err -> return $ Left err + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index f0a7afce15..c70e818d5a 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -56,10 +56,8 @@ data AddPragmaParams = AddPragmaParams -- 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 +addPragmaCmd :: CommandFunction AddPragmaParams +addPragmaCmd _lf _ide (AddPragmaParams uri pragmaName) = do let pos = J.Position 0 0 textEdits = J.List @@ -76,7 +74,7 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do -- | 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 +codeActionProvider _ _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do cmds <- mapM mkCommand pragmas -- cmds <- mapM mkCommand ("FooPragma":pragmas) return $ Right $ List cmds diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index 3c1339433c..c17dcdefab 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -16,6 +16,7 @@ module Ide.Types , HoverProvider , CodeActionProvider , CodeLensProvider + , CommandFunction , ExecuteCommandProvider , CompletionProvider , WithSnippets(..) @@ -27,11 +28,11 @@ 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 Ide.Plugin.Config +import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() @@ -80,11 +81,17 @@ instance IsString CommandId where data PluginCommand = forall a. (FromJSON a) => PluginCommand { commandId :: CommandId , commandDesc :: T.Text - , commandFunc :: a -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + , commandFunc :: CommandFunction a } -- --------------------------------------------------------------------- -type CodeActionProvider = IdeState +type CommandFunction a = LSP.LspFuncs Config + -> IdeState + -> a + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + +type CodeActionProvider = LSP.LspFuncs Config + -> IdeState -> PluginId -> TextDocumentIdentifier -> Range @@ -92,7 +99,8 @@ type CodeActionProvider = IdeState -> IO (Either ResponseError (List CAResult)) -type CodeLensProvider = IdeState +type CodeLensProvider = LSP.LspFuncs Config + -> IdeState -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) @@ -124,7 +132,8 @@ data DiagnosticTrigger = DiagnosticOnOpen -- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -type SymbolsProvider = IdeState +type SymbolsProvider = LSP.LspFuncs Config + -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError [DocumentSymbol]) diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 8a423908b4..cb1e958da5 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -17,19 +17,20 @@ extra-deps: - extra-1.6.18 - floskell-0.10.2 - fuzzy-0.1.0.0 +- ghc-check-0.1.0.3 - ghc-exactprint-0.6.2 # for HaRe - ghc-lib-parser-8.8.1 - ghc-lib-parser-ex-8.8.2 - haddock-api-2.22.0 - haddock-library-1.8.0 -- haskell-lsp-0.20.0.0 -- haskell-lsp-types-0.20.0.0 +- haskell-lsp-0.21.0.0 +- haskell-lsp-types-0.21.0.0 - haskell-src-exts-1.21.1 - hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 -- lsp-test-0.10.1.0 +- lsp-test-0.10.2.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 09e70f6958..5693be1e1f 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -15,13 +15,14 @@ extra-deps: - floskell-0.10.2 # - ghcide-0.1.0 - fuzzy-0.1.0.0 +- ghc-check-0.1.0.3 - ghc-lib-parser-8.8.2 - haddock-library-1.8.0 -- haskell-lsp-0.20.0.0 -- haskell-lsp-types-0.20.0.0 +- haskell-lsp-0.21.0.0 +- haskell-lsp-types-0.21.0.0 - hie-bios-0.4.0 - indexed-profunctors-0.1 -- lsp-test-0.10.1.0 +- lsp-test-0.10.2.0 - monad-dijkstra-0.1.1.2 - optics-core-0.2 - optparse-applicative-0.15.1.0 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index f84a3f4ff5..19cbce6b7b 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -14,14 +14,18 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.2 # - ghcide-0.1.0 +- ghc-check-0.1.0.3 - ghc-lib-parser-ex-8.8.2 - haddock-library-1.8.0 +- haskell-lsp-0.21.0.0 +- haskell-lsp-types-0.21.0.0 - haskell-src-exts-1.21.1 - hie-bios-0.4.0 - hlint-2.2.8 - hoogle-5.0.17.11 - hsimport-0.11.0 - ilist-0.3.1.0 +- lsp-test-0.10.2.0 - monad-dijkstra-0.1.1.2 - semigroups-0.18.5 - temporary-1.2.1.1 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml new file mode 100644 index 0000000000..d4588b9e04 --- /dev/null +++ b/stack-8.8.3.yaml @@ -0,0 +1,42 @@ +resolver: lts-15.5 + +packages: +- . +- ./ghcide/ + +extra-deps: +- apply-refact-0.7.0.0 +- bytestring-trie-0.2.5.0 +# - cabal-helper-1.0.0.0 +- github: DanielG/cabal-helper + commit: a18bbb2af92e9b4337e7f930cb80754f2408bcfd +- clock-0.7.2 +- constrained-dynamic-0.1.0.0 +- floskell-0.10.2 +# - ghcide-0.1.0 +- ghc-check-0.1.0.3 +- ghc-lib-parser-ex-8.8.2 +- haddock-library-1.8.0 +- haskell-lsp-0.21.0.0 +- haskell-lsp-types-0.21.0.0 +- haskell-src-exts-1.21.1 +- hie-bios-0.4.0 +- hlint-2.2.8 +- hoogle-5.0.17.11 +- hsimport-0.11.0 +- ilist-0.3.1.0 +- lsp-test-0.10.2.0 +- monad-dijkstra-0.1.1.2 +- semigroups-0.18.5 +- temporary-1.2.1.1 + +flags: + haskell-language-server: + pedantic: true + +# allow-newer: true + +nix: + packages: [ icu libcxx zlib ] + +concurrent-tests: false diff --git a/stack.yaml b/stack.yaml index 962025b4e5..8c490783b2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,13 +15,14 @@ extra-deps: - floskell-0.10.2 - fuzzy-0.1.0.0 # - ghcide-0.1.0 +- ghc-check-0.1.0.3 - ghc-lib-parser-8.8.2 - haddock-library-1.8.0 -- haskell-lsp-0.20.0.0 -- haskell-lsp-types-0.20.0.0 +- haskell-lsp-0.21.0.0 +- haskell-lsp-types-0.21.0.0 - hie-bios-0.4.0 - indexed-profunctors-0.1 -- lsp-test-0.10.1.0 +- lsp-test-0.10.2.0 - monad-dijkstra-0.1.1.2 - optics-core-0.2 - optparse-applicative-0.15.1.0 diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 09a2d726c7..e51f8741c5 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -90,9 +90,11 @@ spec = do symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse liftIO $ symbolsRsp ^. L.id `shouldBe` responseId id2 - liftIO $ symbolsRsp ^. L.result `shouldBe` - Just (DSDocumentSymbols - (List [DocumentSymbol + + let Just (DSDocumentSymbols (List ds)) = symbolsRsp ^. L.result + liftIO $ length ds `shouldBe` 3 + liftIO $ (take 2 ds) `shouldBe` + [DocumentSymbol "Example_symbol_name" Nothing SkVariable @@ -110,6 +112,6 @@ spec = do , _end = Position {_line = 4, _character = 7}}) (Range {_start = Position {_line = 4, _character = 1} , _end = Position {_line = 4, _character = 7}}) - Nothing])) + Nothing] return ()