hls-eval-plugin 0.2.0.0 → 1.0.0.0
raw patch · 9 files changed
+167/−166 lines, 9 filesdep +lspdep +lsp-typesdep +unliftiodep −haskell-lspdep −haskell-lsp-typesdep ~ghcidedep ~hls-plugin-api
Dependencies added: lsp, lsp-types, unliftio
Dependencies removed: haskell-lsp, haskell-lsp-types
Dependency ranges changed: ghcide, hls-plugin-api
Files
- hls-eval-plugin.cabal +11/−14
- src/Ide/Plugin/Eval.hs +3/−1
- src/Ide/Plugin/Eval/Code.hs +1/−1
- src/Ide/Plugin/Eval/CodeLens.hs +114/−134
- src/Ide/Plugin/Eval/GHC.hs +3/−1
- src/Ide/Plugin/Eval/Parse/Comments.hs +1/−1
- src/Ide/Plugin/Eval/Parse/Option.hs +8/−1
- src/Ide/Plugin/Eval/Types.hs +12/−0
- src/Ide/Plugin/Eval/Util.hs +14/−13
hls-eval-plugin.cabal view
@@ -1,19 +1,14 @@ cabal-version: 2.2 name: hls-eval-plugin-version: 0.2.0.0+version: 1.0.0.0 synopsis: Eval plugin for Haskell Language Server-description:- Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>-+description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme> category: Development bug-reports: https://github.com/haskell/haskell-language-server/issues license: Apache-2.0 license-file: LICENSE-author:- https://github.com/haskell/haskell-language-server/contributors--maintainer:- https://github.com/haskell/haskell-language-server/contributors+author: https://github.com/haskell/haskell-language-server/contributors+maintainer: https://github.com/haskell/haskell-language-server/contributors build-type: Simple extra-source-files:@@ -54,11 +49,11 @@ , ghc , ghc-boot-th , ghc-paths- , ghcide >=0.7.3.0+ , ghcide ^>= 1.0.0.0 , hashable- , haskell-lsp- , haskell-lsp-types- , hls-plugin-api >=0.7+ , lsp+ , lsp-types+ , hls-plugin-api ^>= 1.0.0.0 , lens , megaparsec >=0.9 , mtl@@ -72,10 +67,12 @@ , time , transformers , unordered-containers+ , unliftio - ghc-options: -Wall -Wno-name-shadowing+ ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors if flag(pedantic) ghc-options: -Werror default-language: Haskell2010+ default-extensions: DataKinds, TypeOperators
src/Ide/Plugin/Eval.hs view
@@ -15,12 +15,14 @@ PluginDescriptor (..), PluginId, defaultPluginDescriptor,+ mkPluginHandler )+import Language.LSP.Types -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)- { pluginCodeLensProvider = Just CL.codeLens+ { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand] }
src/Ide/Plugin/Eval/Code.hs view
@@ -24,7 +24,7 @@ import InteractiveEval (runDecls) import Unsafe.Coerce (unsafeCoerce) import Control.Lens ((^.))-import Language.Haskell.LSP.Types.Lens (start, line)+import Language.LSP.Types.Lens (start, line) -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range)
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-}@@ -24,27 +24,23 @@ ) where import Control.Applicative (Alternative ((<|>)))-import Control.Arrow (second)+import Control.Arrow (second, (>>>)) import qualified Control.Exception as E import Control.Monad ( void,- when,+ when, guard,+ join ) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except ( ExceptT (..), )-import Data.Aeson- ( FromJSON,- ToJSON,- toJSON,- )+import Data.Aeson (toJSON) import Data.Char (isSpace)-import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd,- find+ find, intercalate ) import qualified Data.Map.Strict as Map import Data.Maybe@@ -57,27 +53,27 @@ import Data.Time (getCurrentTime) import Data.Typeable (Typeable) import Development.IDE- (realSrcSpanToRange, GetModSummary (..),+ ( Action,+ realSrcSpanToRange, GetModSummary (..), GetParsedModuleWithComments (..),- GhcSession (..),- HscEnvEq (envImportPaths),+ HscEnvEq, IdeState,- List (List),- NormalizedFilePath,- Range (Range),- Uri, evalGhcEnv,- fromNormalizedFilePath, hscEnvWithImportPaths, runAction, textToStringBuffer, toNormalizedFilePath',- toNormalizedUri, uriToFilePath', useWithStale_,- use_,+ prettyPrint,+ use_, useNoFile_, uses_,+ GhcSessionIO(..), GetDependencies(..), GetModIface(..),+ HiFileResult (hirHomeMod, hirModSummary) )-import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile)+import Development.IDE.Core.Rules (TransitiveDependencies(transitiveModuleDeps))+import Development.IDE.Core.Compile (setupFinderCache, loadModulesHome)+import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan, UnhelpfulSpan), srcSpanFile, GhcException, setInteractiveDynFlags)+import Development.IDE.Types.Options import DynamicLoading (initializePlugins) import FastString (unpackFS) import GHC@@ -107,16 +103,14 @@ load, runDecls, setContext,- setInteractiveDynFlags, setLogAction, setSessionDynFlags, setTargets, typeKind, )-import GHC.Generics (Generic)-import qualified GHC.LanguageExtensions.Type as LangExt import GhcPlugins ( DynFlags (..),+ hsc_dflags, defaultLogActionHPutStrDoc, gopt_set, gopt_unset,@@ -125,7 +119,7 @@ updateWays, wayGeneralFlags, wayUnsetGeneralFlags,- xopt_set,+ xopt_set, parseDynamicFlagsCmdLine ) import HscTypes ( InteractiveImport (IIModule),@@ -145,15 +139,14 @@ testRanges, ) import Ide.Plugin.Eval.GHC- ( addExtension,- addImport,+ ( addImport, addPackages, hasPackage, isExpr, showDynFlags, ) import Ide.Plugin.Eval.Parse.Comments (commentsToSections)-import Ide.Plugin.Eval.Parse.Option (langOptions)+import Ide.Plugin.Eval.Parse.Option (parseSetFlags) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util ( asS,@@ -166,41 +159,10 @@ response', timed, )-import Ide.PluginUtils (mkLspCommand) import Ide.Types- ( CodeLensProvider,- CommandFunction,- CommandId,- PluginCommand (PluginCommand),- )-import Language.Haskell.LSP.Core- ( LspFuncs- ( getVirtualFileFunc,- withIndefiniteProgress- ),- ProgressCancellable- ( Cancellable- ),- )-import Language.Haskell.LSP.Types- ( ApplyWorkspaceEditParams- ( ApplyWorkspaceEditParams- ),- CodeLens (CodeLens),- CodeLensParams- ( CodeLensParams,- _textDocument- ),- Command (_arguments, _title),- Position (..),- ServerMethod- ( WorkspaceApplyEdit- ),- TextDocumentIdentifier (..),- TextEdit (TextEdit),- WorkspaceEdit (WorkspaceEdit),- )-import Language.Haskell.LSP.VFS (virtualFileText)+import Language.LSP.Server+import Language.LSP.Types+import Language.LSP.VFS (virtualFileText) import Outputable ( nest, ppr,@@ -211,19 +173,21 @@ ) import System.FilePath (takeFileName) import System.IO (hClose)-import System.IO.Temp (withSystemTempFile)-import Text.Read (readMaybe)+import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL-import Control.Lens ((^.))-import Language.Haskell.LSP.Types.Lens (line, end)+import Control.Lens ((^.), _1, (%~), (<&>), _3)+import Language.LSP.Types.Lens (line, end)+import CmdLineParser+import qualified Development.IDE.GHC.Compat as SrcLoc+import Control.Exception (try) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -}-codeLens :: CodeLensProvider IdeState-codeLens _lsp st plId CodeLensParams{_textDocument} =+codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens+codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $@@ -269,12 +233,12 @@ -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments tests = testsBySection nonSetupSections- cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just [])+ cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) let lenses = [ CodeLens testRange (Just cmd') Nothing- | (section, test) <- tests+ | (section, ident, test) <- tests , let (testRange, resultRange) = testRanges test- args = EvalParams (setupSections ++ [section]) _textDocument+ args = EvalParams (setupSections ++ [section]) _textDocument ident cmd' = (cmd :: Command) { _arguments = Just (List [toJSON args])@@ -308,24 +272,20 @@ evalCommand :: PluginCommand IdeState evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd --- | Specify the test section to execute-data EvalParams = EvalParams- { sections :: [Section]- , module_ :: !TextDocumentIdentifier- }- deriving (Eq, Show, Generic, FromJSON, ToJSON)+type EvalId = Int runEvalCmd :: CommandFunction IdeState EvalParams-runEvalCmd lsp st EvalParams{..} =+runEvalCmd st EvalParams{..} = let dbg = logWith st perf = timed dbg+ cmd :: ExceptT String (LspM c) WorkspaceEdit cmd = do- let tests = testsBySection sections+ let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections let TextDocumentIdentifier{_uri} = module_ fp <- handleMaybe "uri" $ uriToFilePath' _uri let nfp = toNormalizedFilePath' fp- mdlText <- moduleText lsp _uri+ mdlText <- moduleText _uri session <- runGetSession st nfp @@ -344,14 +304,14 @@ (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation- hscEnv' <- withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> ExceptT . (either Left id <$>) . gStrictTry . evalGhcEnv (hscEnvWithImportPaths session) $ do+ hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do env <- getSession -- Install the module pragmas and options df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - let impPaths = fromMaybe (importPaths df) (envImportPaths session)- -- Restore the cradle import paths+ -- Restore the original import paths+ let impPaths = importPaths $ hsc_dflags env df <- return df{importPaths = impPaths} -- Set the modified flags in the session@@ -416,9 +376,9 @@ let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing - return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits)+ return workspaceEdits in perf "evalCmd" $- withIndefiniteProgress lsp "Evaluating" Cancellable $+ withIndefiniteProgress "Evaluating" Cancellable $ response' cmd addFinalReturn :: Text -> [TextEdit] -> [TextEdit]@@ -435,18 +395,19 @@ p = Position l c in TextEdit (Range p p) "\n" -moduleText :: (IsString e, MonadIO m) => LspFuncs c -> Uri -> ExceptT e m Text-moduleText lsp uri =+moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text+moduleText uri = handleMaybeM "mdlText" $- liftIO $- (virtualFileText <$>)- <$> getVirtualFileFunc- lsp- (toNormalizedUri uri)+ (virtualFileText <$>)+ <$> getVirtualFile+ (toNormalizedUri uri) -testsBySection :: [Section] -> [(Section, Test)]+testsBySection :: [Section] -> [(Section, EvalId, Test)] testsBySection sections =- [(section, test) | section <- sections, test <- sectionTests section]+ [(section, ident, test)+ | (ident, section) <- zip [0..] sections+ , test <- sectionTests section+ ] type TEnv = (IdeState, String) @@ -560,20 +521,36 @@ dbg = logWith st eval :: Statement -> Ghc (Maybe [Text]) eval (Located l stmt)- | -- A :set -XLanguageOption directive- isRight (langOptions stmt) =- either- (return . Just . errorLines)- ( \es -> do- dbg "{:SET" es- ndf <- getInteractiveDynFlags- dbg "pre set" $ showDynFlags ndf- mapM_ addExtension es- ndf <- getInteractiveDynFlags- dbg "post set" $ showDynFlags ndf- return Nothing- )- $ ghcOptions stmt+ | -- GHCi flags+ Just (words -> flags) <- parseSetFlags stmt = do+ dbg "{:SET" flags+ ndf <- getInteractiveDynFlags+ dbg "pre set" $ showDynFlags ndf+ eans <-+ liftIO $ try @GhcException $+ parseDynamicFlagsCmdLine ndf+ (map (L $ UnhelpfulSpan "<interactive>") flags)+ dbg "parsed flags" $ eans+ <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg)+ case eans of+ Left err -> pure $ Just $ errorLines $ show err+ Right (df', ignoreds, warns) -> do+ let warnings = do+ guard $ not $ null warns+ pure $ errorLines $+ unlines $+ map prettyWarn warns+ igns = do+ guard $ not $ null ignoreds+ pure+ ["Some flags have not been recognized: "+ <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds)+ ]+ dbg "post set" $ showDynFlags df'+ _ <- setSessionDynFlags df'+ sessDyns <- getSessionDynFlags+ setInteractiveDynFlags sessDyns+ pure $ warnings <> igns | -- A type/kind command Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = evalGhciLikeCmd cmd arg@@ -616,15 +593,35 @@ let opts = execOptions{execSourceFile = fp, execLineNumber = l} in execStmt stmt opts -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnvEq-runGetSession st nfp =- liftIO $- runAction "getSession" st $- use_- GhcSession- -- GhcSessionDeps- nfp+prettyWarn :: Warn -> String+prettyWarn Warn{..} =+ prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n"+ <> " " <> SrcLoc.unLoc warnMsg +ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv+ghcSessionDepsDefinition env file = do+ let hsc = hscEnvWithImportPaths env+ deps <- use_ GetDependencies file+ let tdeps = transitiveModuleDeps deps+ ifaces <- uses_ GetModIface tdeps++ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.+ -- Long-term we might just want to change the order returned by GetDependencies+ let inLoadOrder = reverse (map hirHomeMod ifaces)++ liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc++runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv+runGetSession st nfp = liftIO $ runAction "eval" st $ do+ -- Create a new GHC Session rather than reusing an existing one+ -- to avoid interfering with ghcide+ IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO+ let fp = fromNormalizedFilePath nfp+ ((_, res),_) <- liftIO $ loadSessionFun fp+ let hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res+ ghcSessionDepsDefinition hscEnv nfp+ needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) @@ -645,23 +642,6 @@ . takeWhile (not . ("CallStack" `T.isPrefixOf`)) . T.lines . T.pack--{--Check that extensions actually exists.-->>> ghcOptions ":set -XLambdaCase"-Right [LambdaCase]->>> ghcOptions ":set -XLambdaCase -XNotRight"-Left "Unknown extension: \"NotRight\""--}-ghcOptions :: [Char] -> Either String [LangExt.Extension]-ghcOptions = either Left (mapM chk) . langOptions- where- chk o =- maybe- (Left $ unwords ["Unknown extension:", show o])- Right- (readMaybe o :: Maybe LangExt.Extension) {- | >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])
src/Ide/Plugin/Eval/GHC.hs view
@@ -20,7 +20,7 @@ import qualified EnumSet import GHC.LanguageExtensions.Type (Extension (..)) import GhcMonad (modifySession)-import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC)+import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC, pprHsString) import HscTypes (InteractiveContext (ic_dflags)) import Ide.Plugin.Eval.Util (asS, gStrictTry) import qualified Lexer@@ -36,6 +36,7 @@ import qualified Parser import SrcLoc (mkRealSrcLoc) import StringBuffer (stringToStringBuffer)+import Data.String (fromString) {- $setup >>> import GHC@@ -192,6 +193,7 @@ [ ("extensions", ppr . extensions $ df) , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df) , ("importPaths", vList $ importPaths df)+ , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df) , -- , ("includePaths", text . show $ includePaths df) -- ("packageEnv", ppr $ packageEnv df) ("pkgNames", vcat . map text $ pkgNames df)
src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -32,7 +32,7 @@ import Development.IDE.Types.Location (Position (..)) import GHC.Generics import Ide.Plugin.Eval.Types-import Language.Haskell.LSP.Types.Lens+import Language.LSP.Types.Lens ( character, end, line,
src/Ide/Plugin/Eval/Parse/Option.hs view
@@ -3,9 +3,9 @@ -- | GHC language options parser module Ide.Plugin.Eval.Parse.Option ( langOptions,+ parseSetFlags, ) where -import Control.Monad.Combinators (many) import Text.Megaparsec.Char import Text.Megaparsec import Data.Void (Void)@@ -25,6 +25,13 @@ langOptions = left errorBundlePretty . parse (space *> languageOpts <* eof) ""++parseSetFlags :: String -> Maybe String+parseSetFlags = parseMaybe+ (hspace *> chunk ":set"+ *> hspace1 *> takeRest+ :: Parsec Void String String+ ) -- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings" -- Just ["BinaryLiterals","OverloadedStrings"]
src/Ide/Plugin/Eval/Types.hs view
@@ -25,6 +25,7 @@ RawLineComment (..), unLoc, Txt,+ EvalParams(..), ) where @@ -37,6 +38,7 @@ import Development.IDE (Range) import GHC.Generics (Generic) import qualified Text.Megaparsec as P+import Language.LSP.Types (TextDocumentIdentifier) -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a}@@ -148,3 +150,13 @@ instance IsString LineChunk where fromString = LineChunk++type EvalId = Int++-- | Specify the test section to execute+data EvalParams = EvalParams+ { sections :: [Section]+ , module_ :: !TextDocumentIdentifier+ , evalId :: !EvalId -- ^ unique group id; for test uses+ }+ deriving (Eq, Show, Generic, FromJSON, ToJSON)
src/Ide/Plugin/Eval/Util.hs view
@@ -15,7 +15,7 @@ logWith, ) where -import Control.Monad (join)+import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (@@ -36,10 +36,8 @@ import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch) import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine)-import Language.Haskell.LSP.Types (- ErrorCode (InternalError),- ResponseError (ResponseError),- )+import Language.LSP.Server+import Language.LSP.Types import Outputable ( Outputable (ppr), ppr,@@ -50,6 +48,7 @@ duration, showDuration, )+import UnliftIO.Exception (catchAny) asS :: Outputable a => a -> String asS = showSDocUnsafe . ppr@@ -86,21 +85,23 @@ handleMaybe msg = maybe (throwE msg) return handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b-handleMaybeM msg act = maybe (throwE msg) return =<< lift act+handleMaybeM msg act = maybeM (throwE msg) return $ lift act response :: Functor f => ExceptT String f c -> f (Either ResponseError c) response = fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) . runExceptT -response' :: ExceptT String IO a -> IO (Either ResponseError Value, Maybe a)+response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) response' act = do- res <- gStrictTry $ runExceptT act- case join res of- Left e ->- return- (Left (ResponseError InternalError (fromString e) Nothing), Nothing)- Right a -> return (Right Null, Just a)+ res <- runExceptT act+ `catchAny` showErr+ case res of+ Left e ->+ return $ Left (ResponseError InternalError (fromString e) Nothing)+ Right a -> do+ _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ())+ return $ Right Null gStrictTry :: ExceptionMonad m => m b -> m (Either String b) gStrictTry op =