diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -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 - +description: Please see the README on GitHub at 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 diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -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] } diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -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 "") 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",""]) diff --git a/src/Ide/Plugin/Eval/GHC.hs b/src/Ide/Plugin/Eval/GHC.hs --- a/src/Ide/Plugin/Eval/GHC.hs +++ b/src/Ide/Plugin/Eval/GHC.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/Parse/Comments.hs b/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -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, diff --git a/src/Ide/Plugin/Eval/Parse/Option.hs b/src/Ide/Plugin/Eval/Parse/Option.hs --- a/src/Ide/Plugin/Eval/Parse/Option.hs +++ b/src/Ide/Plugin/Eval/Parse/Option.hs @@ -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"] diff --git a/src/Ide/Plugin/Eval/Types.hs b/src/Ide/Plugin/Eval/Types.hs --- a/src/Ide/Plugin/Eval/Types.hs +++ b/src/Ide/Plugin/Eval/Types.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs --- a/src/Ide/Plugin/Eval/Util.hs +++ b/src/Ide/Plugin/Eval/Util.hs @@ -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 =