From 5cd69a315d023a824d2e86fea5f50684cab27877 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 9 Jul 2020 20:17:55 +0100 Subject: [PATCH 01/12] Eval plugin --- exe/Main.hs | 2 + haskell-language-server.cabal | 4 + src/Ide/Plugin/Eval.hs | 299 ++++++++++++++++++++++++++++++++++ 3 files changed, 305 insertions(+) create mode 100644 src/Ide/Plugin/Eval.hs diff --git a/exe/Main.hs b/exe/Main.hs index a6bbbfb93f..0e4d299900 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -97,6 +97,7 @@ import Development.IDE.Plugin.Completions as Completions import Development.IDE.LSP.HoverDefinition as HoverDefinition -- haskell-language-server plugins +import Ide.Plugin.Eval as Eval import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Ide.Plugin.GhcIde as GhcIde @@ -143,6 +144,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #if AGPL , Brittany.descriptor "brittany" #endif + , Eval.descriptor "eval" ] examplePlugins = [Example.descriptor "eg" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a74e4a92c0..b437a5d773 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -42,6 +42,7 @@ library Ide.Logger Ide.Plugin Ide.Plugin.Config + Ide.Plugin.Eval Ide.Plugin.Example Ide.Plugin.Example2 Ide.Plugin.GhcIde @@ -68,6 +69,7 @@ library , deepseq , Diff , directory + , exceptions , extra , filepath , floskell == 0.10.* @@ -83,9 +85,11 @@ library , optparse-simple , process , regex-tdfa >= 1.3.1.0 + , rope-utf16-splay , shake >= 0.17.5 , stylish-haskell == 0.11.* , text + , time , transformers , unordered-containers if os(windows) diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs new file mode 100644 index 0000000000..7a27fd4b00 --- /dev/null +++ b/src/Ide/Plugin/Eval.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | A plugin inspired by the REPLoid feature of Dante[1] which allows +-- to evaluate code in comment prompts and splice the results right below: +-- +-- > example :: [String] +-- > example = ["This is an example", "of", "interactive", "evaluation"] +-- > +-- > -- >>> intercalate " " example +-- > -- "This is an example of interactive evaluation" +-- > -- +-- +-- [1] - https://github.com/jyp/dante +module Ide.Plugin.Eval where + +import Control.Monad (void) +import Control.Monad.Catch (finally) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, + throwE) +import Data.Aeson (FromJSON, ToJSON, Value (Null), + toJSON) +import Data.Bifunctor (Bifunctor (first)) +import qualified Data.HashMap.Strict as Map +import qualified Data.Rope.UTF16 as Rope +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Development.IDE.Core.Rules (runAction) +import Development.IDE.Core.RuleTypes (GetModSummary (..), + GhcSessionDeps (..)) +import Development.IDE.Core.Shake (use_) +import Development.IDE.GHC.Util (evalGhcEnv, hscEnv, + textToStringBuffer) +import Development.IDE.Types.Location (toNormalizedFilePath', + uriToFilePath') +import DynamicLoading (initializePlugins) +import GHC +import GHC.Generics (Generic) +import GhcMonad (modifySession) +import GhcPlugins (defaultLogActionHPutStrDoc, + gopt_set, gopt_unset, + interpWays, updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags) +import HscTypes +import Ide.Plugin +import Ide.Types +import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc)) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.VFS (VirtualFile (..)) +import PrelNames (pRELUDE) +import System.IO (IOMode (WriteMode), hClose, openFile) +import System.IO.Extra (newTempFile) + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = + (defaultPluginDescriptor plId) + { pluginId = plId, + pluginCodeLensProvider = Just provider, + pluginCommands = [evalCommand] + } + +extractMatches :: Maybe Text -> [([(Text, Int)], Range)] +extractMatches = goSearch 0 . maybe [] T.lines + where + checkMatch = T.stripPrefix "-- >>> " + looksLikeSplice l + | Just l' <- T.stripPrefix "--" l + = not (" >>>" `T.isPrefixOf` l') + | otherwise + = False + + goSearch _ [] = [] + goSearch line (l : ll) + | Just match <- checkMatch l = + goAcc (line + 1) [(match, line)] ll + | otherwise = + goSearch (line + 1) ll + + goAcc line acc [] = [(reverse acc,Range p p)] where p = Position line 0 + goAcc line acc (l:ll) + | Just match <- checkMatch l = + goAcc (line + 1) ([(match, line)] <> acc) ll + | otherwise = + (reverse acc,r) : goSearch (line + 1) ll + where + r = Range p p' + p = Position line 0 + p' = Position (line + spliceLength) 0 + spliceLength = length (takeWhile looksLikeSplice (l:ll)) + +provider :: CodeLensProvider +provider lsp _state plId CodeLensParams {_textDocument} = response $ do + let TextDocumentIdentifier uri = _textDocument + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri + let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents + let matches = extractMatches text + + cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate..." (Just []) + + let lenses = + [ CodeLens range (Just cmd') Nothing + | (m, r) <- matches, + let (_, startLine) = head m + (_, endLine) = last m + range = Range start end + start = Position startLine 0 + end = Position endLine 1000 + args = EvalParams m r _textDocument, + let cmd' = (cmd :: Command) + {_arguments = Just (List [toJSON args]) + ,_title = if trivial r then "Evaluate..." else "Refresh..." + } + ] + + return $ List lenses + where + trivial (Range p p') = p == p' + +evalCommandName :: CommandId +evalCommandName = "evalCommand" + +evalCommand :: PluginCommand +evalCommand = + PluginCommand evalCommandName "evaluate" runEvalCmd + +data EvalParams = EvalParams + { statements :: [(Text, Int)], + editTarget :: !Range, + module_ :: !TextDocumentIdentifier + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +runEvalCmd :: CommandFunction EvalParams +runEvalCmd lsp state EvalParams {..} = response' $ do + let TextDocumentIdentifier {_uri} = module_ + fp <- handleMaybe "uri" $ uriToFilePath' _uri + contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri _uri + text <- handleMaybe "contents" $ Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents + + session <- + liftIO + $ runAction "runEvalCmd.ghcSession" state + $ use_ GhcSessionDeps + $ toNormalizedFilePath' + $ fp + + ms <- + liftIO + $ runAction "runEvalCmd.getModSummary" state + $ use_ GetModSummary + $ toNormalizedFilePath' + $ fp + + now <- liftIO getCurrentTime + + (temp, clean) <- liftIO newTempFile + (tempLog, cleanLog) <- liftIO newTempFile + hLog <- liftIO $ openFile tempLog WriteMode + flip finally (liftIO $ hClose hLog >> cleanLog >> clean) $ do + let modName = moduleName $ ms_mod ms + thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now)) + + hscEnv' <- ExceptT $ evalGhcEnv (hscEnv session) $ do + df <- getSessionDynFlags + env <- getSession + df <- liftIO $ setupDynFlagsForGHCiLike env df + _lp <- setSessionDynFlags df + + -- copy the package state to the interactive DynFlags + idflags <- getInteractiveDynFlags + df <- getSessionDynFlags + setInteractiveDynFlags + idflags + { pkgState = pkgState df, + pkgDatabase = pkgDatabase df, + packageFlags = packageFlags df + } + + -- set up a custom log action + setLogAction $ \_df _wr _sev _span _style _doc -> + defaultLogActionHPutStrDoc _df hLog _doc _style + + -- load the module in the interactive environment + setTargets [thisModuleTarget] + loadResult <- load LoadAllTargets + case loadResult of + Failed -> liftIO $ do + hClose hLog + Left <$> readFile tempLog + Succeeded -> do + setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE), IIModule modName] + Right <$> getSession + + df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags + let eval (stmt, l) + | isStmt df stmt = do + + -- set up a custom interactive print function + ctxt <- getContext + setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)] + let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)" + interactivePrint <- execStmt printFun execOptions >>= \case + ExecComplete (Right [interactivePrint]) _ -> pure interactivePrint + _ -> error "internal error binding print function" + modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) interactivePrint} + setContext ctxt + + let opts = + execOptions + { execSourceFile = fp, + execLineNumber = l + } + res <- execStmt stmt opts + str <- case res of + ExecComplete (Left err) _ -> pure $ pad $ show err + ExecComplete (Right _) _ -> liftIO $ pad <$> readFile temp + ExecBreak {} -> pure $ pad "breakpoints are not supported" + + let changes = [TextEdit editTarget $ T.pack str] + return changes + + | isImport df stmt = do + ctxt <- getContext + idecl <- parseImportDecl stmt + setContext $ IIDecl idecl : ctxt + return [] + + | otherwise = do + void $ runDecls stmt + return [] + + edits <- liftIO $ evalGhcEnv hscEnv' $ traverse (eval . first T.unpack) statements + + let workspaceEditsMap = Map.fromList [(_uri, List $ concat edits)] + let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing + + return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) + +pad :: String -> String +pad = unlines . map ("-- " <>) . lines + +------------------------------------------------------------------------------- + +handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b +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 + +response :: ExceptT String IO a -> IO (Either ResponseError a) +response = + fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) + . runExceptT + +response' :: ExceptT String IO a -> IO (Either ResponseError Value, Maybe a) +response' act = do + res <- runExceptT act + case res of + Left e -> + return (Left (ResponseError InternalError (fromString e) Nothing), Nothing) + Right a -> return (Right Null, Just a) + +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike env dflags = do + let dflags3 = + dflags + { hscTarget = HscInterpreted, + ghcMode = CompManager, + ghcLink = LinkInMemory + } + platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 {ways = interpWays} + dflags3b = + foldl gopt_set dflags3a $ + concatMap + (wayGeneralFlags platform) + interpWays + dflags3c = + foldl gopt_unset dflags3b $ + concatMap + (wayUnsetGeneralFlags platform) + interpWays + dflags4 = + dflags3c `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + initializePlugins env dflags4 From 91c2b20dbae758cf175971ed07bf2ba2fb13a4d7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 08:41:39 +0100 Subject: [PATCH 02/12] review feedbacks --- haskell-language-server.cabal | 1 - src/Ide/Plugin/Eval.hs | 29 +++++++++++++++++++---------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b437a5d773..e2f72833e8 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -85,7 +85,6 @@ library , optparse-simple , process , regex-tdfa >= 1.3.1.0 - , rope-utf16-splay , shake >= 0.17.5 , stylish-haskell == 0.11.* , text diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 7a27fd4b00..44fcd3c62a 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -22,7 +22,7 @@ module Ide.Plugin.Eval where import Control.Monad (void) -import Control.Monad.Catch (finally) +import Control.Monad.Catch (MonadMask, bracket) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, @@ -31,7 +31,6 @@ import Data.Aeson (FromJSON, ToJSON, Value (Null), toJSON) import Data.Bifunctor (Bifunctor (first)) import qualified Data.HashMap.Strict as Map -import qualified Data.Rope.UTF16 as Rope import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T @@ -58,9 +57,9 @@ import Ide.Plugin import Ide.Types import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc)) import Language.Haskell.LSP.Types -import Language.Haskell.LSP.VFS (VirtualFile (..)) +import Language.Haskell.LSP.VFS (virtualFileText) import PrelNames (pRELUDE) -import System.IO (IOMode (WriteMode), hClose, openFile) +import System.IO (Handle, IOMode (WriteMode), hClose, openFile) import System.IO.Extra (newTempFile) descriptor :: PluginId -> PluginDescriptor @@ -104,7 +103,7 @@ provider :: CodeLensProvider provider lsp _state plId CodeLensParams {_textDocument} = response $ do let TextDocumentIdentifier uri = _textDocument contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri uri - let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents + let text = virtualFileText <$> contents let matches = extractMatches text cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate..." (Just []) @@ -147,7 +146,7 @@ runEvalCmd lsp state EvalParams {..} = response' $ do let TextDocumentIdentifier {_uri} = module_ fp <- handleMaybe "uri" $ uriToFilePath' _uri contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri _uri - text <- handleMaybe "contents" $ Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents + text <- handleMaybe "contents" $ virtualFileText <$> contents session <- liftIO @@ -165,10 +164,7 @@ runEvalCmd lsp state EvalParams {..} = response' $ do now <- liftIO getCurrentTime - (temp, clean) <- liftIO newTempFile - (tempLog, cleanLog) <- liftIO newTempFile - hLog <- liftIO $ openFile tempLog WriteMode - flip finally (liftIO $ hClose hLog >> cleanLog >> clean) $ do + withTempFile $ \temp -> withTempFile $ \tempLog -> withFile tempLog WriteMode $ \hLog -> do let modName = moduleName $ ms_mod ms thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now)) @@ -297,3 +293,16 @@ setupDynFlagsForGHCiLike env dflags = do `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges initializePlugins env dflags4 + + +withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m a) -> m a +withTempFile k = bracket alloc release (k . fst) + where + alloc = liftIO newTempFile + release = liftIO . snd + +withFile :: (MonadMask m, MonadIO m) => FilePath -> IOMode -> (Handle -> m b) -> m b +withFile f mode = bracket alloc release + where + alloc = liftIO $ openFile f mode + release = liftIO . hClose From d37d436a132b06809a874758c0d6e50b47c35d8b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 09:10:11 +0100 Subject: [PATCH 03/12] compatibility with GHC 8.8 --- src/Ide/Plugin/Eval.hs | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 44fcd3c62a..1567337dc1 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -44,7 +44,28 @@ import Development.IDE.GHC.Util (evalGhcEnv, hscEnv, import Development.IDE.Types.Location (toNormalizedFilePath', uriToFilePath') import DynamicLoading (initializePlugins) -import GHC +import DynFlags (targetPlatform) +import GHC (DynFlags, ExecResult (..), + GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), + GhcLink (LinkInMemory), + GhcMode (CompManager), + HscTarget (HscInterpreted), + LoadHowMuch (LoadAllTargets), + SuccessFlag (..), + execLineNumber, execOptions, + execSourceFile, execStmt, + getContext, + getInteractiveDynFlags, + getSession, getSessionDynFlags, + ghcLink, ghcMode, hscTarget, + isImport, isStmt, load, + moduleName, packageFlags, + parseImportDecl, pkgDatabase, + pkgState, runDecls, setContext, + setInteractiveDynFlags, + setLogAction, + setSessionDynFlags, setTargets, + simpleImportDecl, ways) import GHC.Generics (Generic) import GhcMonad (modifySession) import GhcPlugins (defaultLogActionHPutStrDoc, @@ -59,7 +80,8 @@ import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc)) import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS (virtualFileText) import PrelNames (pRELUDE) -import System.IO (Handle, IOMode (WriteMode), hClose, openFile) +import System.IO (Handle, IOMode (WriteMode), + hClose, openFile) import System.IO.Extra (newTempFile) descriptor :: PluginId -> PluginDescriptor From 7e2d3bc77d25d8396b35b120516b658e1298267c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 13:07:47 +0100 Subject: [PATCH 04/12] Bugfixes, formatting, temporary --- haskell-language-server.cabal | 2 +- src/Ide/Plugin/Eval.hs | 161 ++++++++++++++++------------------ 2 files changed, 77 insertions(+), 86 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index e2f72833e8..bb5a23dd95 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -69,7 +69,6 @@ library , deepseq , Diff , directory - , exceptions , extra , filepath , floskell == 0.10.* @@ -87,6 +86,7 @@ library , regex-tdfa >= 1.3.1.0 , shake >= 0.17.5 , stylish-haskell == 0.11.* + , temporary , text , time , transformers diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 1567337dc1..2a3aa18d89 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -22,7 +22,6 @@ module Ide.Plugin.Eval where import Control.Monad (void) -import Control.Monad.Catch (MonadMask, bracket) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, @@ -45,8 +44,7 @@ import Development.IDE.Types.Location (toNormalizedFilePath', uriToFilePath') import DynamicLoading (initializePlugins) import DynFlags (targetPlatform) -import GHC (DynFlags, ExecResult (..), - GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), +import GHC (DynFlags, ExecResult (..), GeneralFlag (Opt_IgnoreHpcChanges, Opt_IgnoreOptimChanges, Opt_ImplicitImportQualified), GhcLink (LinkInMemory), GhcMode (CompManager), HscTarget (HscInterpreted), @@ -80,9 +78,9 @@ import Language.Haskell.LSP.Core (LspFuncs (getVirtualFileFunc)) import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS (virtualFileText) import PrelNames (pRELUDE) -import System.IO (Handle, IOMode (WriteMode), - hClose, openFile) -import System.IO.Extra (newTempFile) +import System.FilePath +import System.IO (hClose) +import System.IO.Temp descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -97,10 +95,10 @@ extractMatches = goSearch 0 . maybe [] T.lines where checkMatch = T.stripPrefix "-- >>> " looksLikeSplice l - | Just l' <- T.stripPrefix "--" l - = not (" >>>" `T.isPrefixOf` l') - | otherwise - = False + | Just l' <- T.stripPrefix "--" l = + not (" >>>" `T.isPrefixOf` l') + | otherwise = + False goSearch _ [] = [] goSearch line (l : ll) @@ -109,17 +107,17 @@ extractMatches = goSearch 0 . maybe [] T.lines | otherwise = goSearch (line + 1) ll - goAcc line acc [] = [(reverse acc,Range p p)] where p = Position line 0 - goAcc line acc (l:ll) + goAcc line acc [] = [(reverse acc, Range p p)] where p = Position line 0 + goAcc line acc (l : ll) | Just match <- checkMatch l = goAcc (line + 1) ([(match, line)] <> acc) ll | otherwise = - (reverse acc,r) : goSearch (line + 1) ll + (reverse acc, r) : goSearch (line + 1) ll where r = Range p p' p = Position line 0 p' = Position (line + spliceLength) 0 - spliceLength = length (takeWhile looksLikeSplice (l:ll)) + spliceLength = length (takeWhile looksLikeSplice (l : ll)) provider :: CodeLensProvider provider lsp _state plId CodeLensParams {_textDocument} = response $ do @@ -134,20 +132,21 @@ provider lsp _state plId CodeLensParams {_textDocument} = response $ do [ CodeLens range (Just cmd') Nothing | (m, r) <- matches, let (_, startLine) = head m - (_, endLine) = last m + (endLineContents, endLine) = last m range = Range start end start = Position startLine 0 - end = Position endLine 1000 + end = Position endLine (T.length endLineContents) args = EvalParams m r _textDocument, - let cmd' = (cmd :: Command) - {_arguments = Just (List [toJSON args]) - ,_title = if trivial r then "Evaluate..." else "Refresh..." + let cmd' = + (cmd :: Command) + { _arguments = Just (List [toJSON args]), + _title = if trivial r then "Evaluate..." else "Refresh..." } ] return $ List lenses where - trivial (Range p p') = p == p' + trivial (Range p p') = p == p' evalCommandName :: CommandId evalCommandName = "evalCommand" @@ -171,93 +170,98 @@ runEvalCmd lsp state EvalParams {..} = response' $ do text <- handleMaybe "contents" $ virtualFileText <$> contents session <- - liftIO - $ runAction "runEvalCmd.ghcSession" state - $ use_ GhcSessionDeps - $ toNormalizedFilePath' - $ fp + liftIO $ + runAction "runEvalCmd.ghcSession" state $ + use_ GhcSessionDeps $ + toNormalizedFilePath' $ + fp ms <- - liftIO - $ runAction "runEvalCmd.getModSummary" state - $ use_ GetModSummary - $ toNormalizedFilePath' - $ fp + liftIO $ + runAction "runEvalCmd.getModSummary" state $ + use_ GetModSummary $ + toNormalizedFilePath' $ + fp now <- liftIO getCurrentTime - withTempFile $ \temp -> withTempFile $ \tempLog -> withFile tempLog WriteMode $ \hLog -> do + let tmp = withSystemTempFile (takeFileName fp) + + tmp $ \temp _h -> tmp $ \tempLog hLog -> do + liftIO $ hClose _h let modName = moduleName $ ms_mod ms thisModuleTarget = Target (TargetFile fp Nothing) False (Just (textToStringBuffer text, now)) - hscEnv' <- ExceptT $ evalGhcEnv (hscEnv session) $ do - df <- getSessionDynFlags - env <- getSession - df <- liftIO $ setupDynFlagsForGHCiLike env df - _lp <- setSessionDynFlags df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - setInteractiveDynFlags - idflags - { pkgState = pkgState df, - pkgDatabase = pkgDatabase df, - packageFlags = packageFlags df - } - - -- set up a custom log action - setLogAction $ \_df _wr _sev _span _style _doc -> - defaultLogActionHPutStrDoc _df hLog _doc _style - - -- load the module in the interactive environment - setTargets [thisModuleTarget] - loadResult <- load LoadAllTargets - case loadResult of - Failed -> liftIO $ do + hscEnv' <- ExceptT $ + evalGhcEnv (hscEnv session) $ do + df <- getSessionDynFlags + env <- getSession + df <- liftIO $ setupDynFlagsForGHCiLike env df + _lp <- setSessionDynFlags df + + -- copy the package state to the interactive DynFlags + idflags <- getInteractiveDynFlags + df <- getSessionDynFlags + setInteractiveDynFlags + idflags + { pkgState = pkgState df, + pkgDatabase = pkgDatabase df, + packageFlags = packageFlags df + } + + -- set up a custom log action + setLogAction $ \_df _wr _sev _span _style _doc -> + defaultLogActionHPutStrDoc _df hLog _doc _style + + -- load the module in the interactive environment + setTargets [thisModuleTarget] + loadResult <- load LoadAllTargets + case loadResult of + Failed -> liftIO $ do hClose hLog Left <$> readFile tempLog - Succeeded -> do + Succeeded -> do setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE), IIModule modName] Right <$> getSession df <- liftIO $ evalGhcEnv hscEnv' getSessionDynFlags let eval (stmt, l) | isStmt df stmt = do - -- set up a custom interactive print function ctxt <- getContext setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)] let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)" - interactivePrint <- execStmt printFun execOptions >>= \case + interactivePrint <- + execStmt printFun execOptions >>= \case ExecComplete (Right [interactivePrint]) _ -> pure interactivePrint _ -> error "internal error binding print function" modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) interactivePrint} setContext ctxt let opts = - execOptions + execOptions { execSourceFile = fp, - execLineNumber = l + execLineNumber = l } res <- execStmt stmt opts str <- case res of - ExecComplete (Left err) _ -> pure $ pad $ show err - ExecComplete (Right _) _ -> liftIO $ pad <$> readFile temp - ExecBreak {} -> pure $ pad "breakpoints are not supported" + ExecComplete (Left err) _ -> pure $ pad $ show err + ExecComplete (Right _) _ -> do + out <- liftIO $ pad <$> readFile temp + let forceIt = length out + return $! forceIt `seq` out + ExecBreak {} -> pure $ pad "breakpoints are not supported" let changes = [TextEdit editTarget $ T.pack str] return changes - | isImport df stmt = do - ctxt <- getContext - idecl <- parseImportDecl stmt - setContext $ IIDecl idecl : ctxt - return [] - + ctxt <- getContext + idecl <- parseImportDecl stmt + setContext $ IIDecl idecl : ctxt + return [] | otherwise = do - void $ runDecls stmt - return [] + void $ runDecls stmt + return [] edits <- liftIO $ evalGhcEnv hscEnv' $ traverse (eval . first T.unpack) statements @@ -315,16 +319,3 @@ setupDynFlagsForGHCiLike env dflags = do `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges initializePlugins env dflags4 - - -withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m a) -> m a -withTempFile k = bracket alloc release (k . fst) - where - alloc = liftIO newTempFile - release = liftIO . snd - -withFile :: (MonadMask m, MonadIO m) => FilePath -> IOMode -> (Handle -> m b) -> m b -withFile f mode = bracket alloc release - where - alloc = liftIO $ openFile f mode - release = liftIO . hClose From 67744c479f64275f0572cb353c00877fce15474d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 13:08:12 +0100 Subject: [PATCH 05/12] Tests --- haskell-language-server.cabal | 1 + test/functional/Eval.hs | 66 +++++++++++++++++++++++++++++++ test/functional/Main.hs | 4 +- test/testdata/eval/T1.hs | 7 ++++ test/testdata/eval/T1.hs.expected | 8 ++++ test/testdata/eval/T2.hs | 8 ++++ test/testdata/eval/T2.hs.expected | 8 ++++ test/testdata/eval/T3.hs | 7 ++++ test/testdata/eval/T3.hs.expected | 8 ++++ test/testdata/eval/T4.hs | 8 ++++ test/testdata/eval/T4.hs.expected | 9 +++++ test/testdata/eval/test.cabal | 17 ++++++++ 12 files changed, 150 insertions(+), 1 deletion(-) create mode 100644 test/functional/Eval.hs create mode 100644 test/testdata/eval/T1.hs create mode 100644 test/testdata/eval/T1.hs.expected create mode 100644 test/testdata/eval/T2.hs create mode 100644 test/testdata/eval/T2.hs.expected create mode 100644 test/testdata/eval/T3.hs create mode 100644 test/testdata/eval/T3.hs.expected create mode 100644 test/testdata/eval/T4.hs create mode 100644 test/testdata/eval/T4.hs.expected create mode 100644 test/testdata/eval/test.cabal diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bb5a23dd95..d4095fa735 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -274,6 +274,7 @@ test-suite func-test , Deferred , Definition , Diagnostic + , Eval , Format , FunctionalBadProject , FunctionalCodeAction diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs new file mode 100644 index 0000000000..d48bfff09e --- /dev/null +++ b/test/functional/Eval.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Eval (tests) where + +import Control.Applicative.Combinators (skipManyTill) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Text.IO as T +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types (ApplyWorkspaceEditRequest, + CodeLens (CodeLens, _command, _range), + Command (_title), + Position (..), Range (..)) +import System.FilePath +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "eval" + [ testCase "Produces Evaluate code lenses" $ do + runSession hieCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Evaluate..."], + testCase "Produces Refresh code lenses" $ do + runSession hieCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map (fmap _title . _command) lenses @?= [Just "Refresh..."], + testCase "Code lenses have ranges" $ do + runSession hieCommand fullCaps evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)], + testCase "Multi-line expressions have a multi-line range" $ do + runSession hieCommand fullCaps evalPath $ do + doc <- openDoc "T3.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 3 0) (Position 4 15)], + testCase "Executed expressions range covers only the expression" $ do + runSession hieCommand fullCaps evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getCodeLenses doc + liftIO $ map _range lenses @?= [Range (Position 4 0) (Position 4 15)], + testCase "Evaluation of expressions" $ goldenTest "T1.hs", + testCase "Reevaluation of expressions" $ goldenTest "T2.hs", + testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs", + testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" + ] + +goldenTest :: FilePath -> IO () +goldenTest input = runSession hieCommand fullCaps evalPath $ do + doc <- openDoc input "haskell" + [CodeLens {_command = Just c}] <- getCodeLenses doc + executeCommand c + _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message + edited <- documentContents doc + expected <- liftIO $ T.readFile $ evalPath input <.> "expected" + liftIO $ edited @?= expected + +evalPath :: FilePath +evalPath = "test/testdata/eval" diff --git a/test/functional/Main.hs b/test/functional/Main.hs index 7bffaf33d3..328a0e502f 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -10,6 +10,7 @@ import Completion import Deferred import Definition import Diagnostic +import Eval import Format import FunctionalBadProject import FunctionalCodeAction @@ -36,6 +37,7 @@ main = , Deferred.tests , Definition.tests , Diagnostic.tests + , Eval.tests , Format.tests , FunctionalBadProject.tests , FunctionalCodeAction.tests @@ -47,4 +49,4 @@ main = , Rename.tests , Symbol.tests , TypeDefinition.tests - ] \ No newline at end of file + ] diff --git a/test/testdata/eval/T1.hs b/test/testdata/eval/T1.hs new file mode 100644 index 0000000000..485cbf3748 --- /dev/null +++ b/test/testdata/eval/T1.hs @@ -0,0 +1,7 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T1.hs.expected b/test/testdata/eval/T1.hs.expected new file mode 100644 index 0000000000..622b9c1f85 --- /dev/null +++ b/test/testdata/eval/T1.hs.expected @@ -0,0 +1,8 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T2.hs b/test/testdata/eval/T2.hs new file mode 100644 index 0000000000..82e37b8b5a --- /dev/null +++ b/test/testdata/eval/T2.hs @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "Stale output" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T2.hs.expected b/test/testdata/eval/T2.hs.expected new file mode 100644 index 0000000000..48b3a52baf --- /dev/null +++ b/test/testdata/eval/T2.hs.expected @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T3.hs b/test/testdata/eval/T3.hs new file mode 100644 index 0000000000..82e87a040b --- /dev/null +++ b/test/testdata/eval/T3.hs @@ -0,0 +1,7 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T3.hs.expected b/test/testdata/eval/T3.hs.expected new file mode 100644 index 0000000000..50fb1a7bfd --- /dev/null +++ b/test/testdata/eval/T3.hs.expected @@ -0,0 +1,8 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T4.hs b/test/testdata/eval/T4.hs new file mode 100644 index 0000000000..72c88ed1d4 --- /dev/null +++ b/test/testdata/eval/T4.hs @@ -0,0 +1,8 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/eval/T4.hs.expected b/test/testdata/eval/T4.hs.expected new file mode 100644 index 0000000000..4b56dbf392 --- /dev/null +++ b/test/testdata/eval/T4.hs.expected @@ -0,0 +1,9 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/eval/test.cabal b/test/testdata/eval/test.cabal new file mode 100644 index 0000000000..fbc943a651 --- /dev/null +++ b/test/testdata/eval/test.cabal @@ -0,0 +1,17 @@ +name: test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: T1, T2, T3, T4 + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports From 890431936e934b23ce9c6f8ff3195e537e869109 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 23:29:34 +0100 Subject: [PATCH 06/12] Add ignored hie.yaml file --- test/testdata/eval/hie.yaml | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/testdata/eval/hie.yaml diff --git a/test/testdata/eval/hie.yaml b/test/testdata/eval/hie.yaml new file mode 100644 index 0000000000..a2e9ed5148 --- /dev/null +++ b/test/testdata/eval/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["T1", "T2", "T3", "T4"]}} From c9c93f58a962e3f0134f1bb8f155ddef7c9eb759 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 11 Jul 2020 23:30:15 +0100 Subject: [PATCH 07/12] Do not ignore testdata hie.yaml files This is surprising and unexpected - I wasted a lot of time debugging test failures in CI that worked fine locally --- .gitignore | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/.gitignore b/.gitignore index 395b29dc79..9058bdc494 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,6 @@ dist-newstyle .stack-work -hie.yaml +/hie.yaml cabal.project.local *~ *.lock @@ -19,8 +19,5 @@ shake.yaml.lock stack*.yaml.lock shake.yaml.lock -# ignore hie.yaml's for testdata -test/**/*.yaml - # metadata files on macOS .DS_Store From c767e0a84af061e6bc9524db562f3a99d32c0448 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 12 Jul 2020 12:58:09 +0100 Subject: [PATCH 08/12] Revert back to GhcSession rule Depending on GhcSessionDeps means we do not need to reload all the module dependencies in the GHC session. On the other hand, with the GhcSession dependency we *do* have to reload them (from interface files, hopefully) Unfortunately, the ModSummary objects that GhcSessionDeps puts in the GHC session are not suitable for reuse since they clear out the timestamps to avoid internal bugs. This can probably be relaxed so that plugins like Eval can reuse them. --- src/Ide/Plugin/Eval.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 2a3aa18d89..8936079361 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -36,7 +36,7 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (GetModSummary (..), - GhcSessionDeps (..)) + GhcSession (..)) import Development.IDE.Core.Shake (use_) import Development.IDE.GHC.Util (evalGhcEnv, hscEnv, textToStringBuffer) @@ -169,10 +169,22 @@ runEvalCmd lsp state EvalParams {..} = response' $ do contents <- liftIO $ getVirtualFileFunc lsp $ toNormalizedUri _uri text <- handleMaybe "contents" $ virtualFileText <$> contents +{- Note: GhcSessionDeps + +Depending on GhcSession means we do need to reload all the module +dependencies in the GHC session(from interface files, hopefully). + +The GhcSessionDeps dependency would allow us to reuse a GHC session preloaded +with all the dependencies. Unfortunately, the ModSummary objects that +GhcSessionDeps puts in the GHC session are not suitable for reuse since they +clear out the timestamps; this is done to avoid internal ghcide bugs and +can probably be relaxed so that plugins like Eval can reuse them. Once that's +done, we want to switch back to GhcSessionDeps + -} session <- liftIO $ runAction "runEvalCmd.ghcSession" state $ - use_ GhcSessionDeps $ + use_ GhcSession $ -- See the note on GhcSessionDeps toNormalizedFilePath' $ fp From e7a755394e1ef9ce66e29b396ca5cd7fc37b3a93 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 12 Jul 2020 13:25:55 +0100 Subject: [PATCH 09/12] Add (empty) features section to README --- README.md | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index ec5aff50b3..ee992c3452 100644 --- a/README.md +++ b/README.md @@ -15,6 +15,7 @@ background](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-th This is *very* early stage software. - [Haskell Language Server (HLS)](#haskell-language-server) + - [Features](#features) - [Installation](#installation) - [Installation from source](#installation-from-source) - [Common pre-requirements](#common-pre-requirements) @@ -43,6 +44,14 @@ This is *very* early stage software. - [Contributing](#contributing) - [It's time to join the project!](#its-time-to-join-the-project) +## Features + + - Code evaluation (inspired by [Dante](https://github.com/jyp/dante#-reploid)) + + ![Eval](https://imgur.com/PDuZ6z8) + + - Many more (TBD) + ## Installation For now only installation from source is supported. @@ -490,7 +499,7 @@ args = ["--lsp"] ## Known limitations ### Preprocessor -HLS is not yet able to find project preprocessors, which may result in `could not execute: ` errors. This problem is +HLS is not yet able to find project preprocessors, which may result in `could not execute: ` errors. This problem is tracked in https://github.com/haskell/haskell-language-server/issues/176 and originally comes from https://github.com/mpickering/hie-bios/issues/125 As a workaround, you need to ensure the preprocessor is available in the path (install globally with Stack or Cabal, provide in `shell.nix`, etc.). From d69200f34e1f1930c0a879a5d4e0acb5e99b4216 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 12 Jul 2020 13:29:53 +0100 Subject: [PATCH 10/12] Fix eval screen rec --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ee992c3452..bcaa7b8531 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ This is *very* early stage software. - Code evaluation (inspired by [Dante](https://github.com/jyp/dante#-reploid)) - ![Eval](https://imgur.com/PDuZ6z8) + ![Eval](https://i.imgur.com/bh992sT.gif) - Many more (TBD) From 05a19999b6e2a47b83c97090bf4e99915ae13377 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Jul 2020 21:32:19 +0100 Subject: [PATCH 11/12] Add a test for reevaluation --- test/functional/Eval.hs | 3 ++- test/testdata/eval/T5.hs | 6 ++++++ test/testdata/eval/T5.hs.expected | 6 ++++++ 3 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 test/testdata/eval/T5.hs create mode 100644 test/testdata/eval/T5.hs.expected diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs index d48bfff09e..31108ec419 100644 --- a/test/functional/Eval.hs +++ b/test/functional/Eval.hs @@ -49,7 +49,8 @@ tests = testCase "Evaluation of expressions" $ goldenTest "T1.hs", testCase "Reevaluation of expressions" $ goldenTest "T2.hs", testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs", - testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" + testCase "Refresh an evaluation" $ goldenTest "T5.hs" + testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs", ] goldenTest :: FilePath -> IO () diff --git a/test/testdata/eval/T5.hs b/test/testdata/eval/T5.hs new file mode 100644 index 0000000000..18887a91e1 --- /dev/null +++ b/test/testdata/eval/T5.hs @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/eval/T5.hs.expected b/test/testdata/eval/T5.hs.expected new file mode 100644 index 0000000000..4fe595e671 --- /dev/null +++ b/test/testdata/eval/T5.hs.expected @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] From 184d0bd63eff07e5a837c2f34a5ead8ee36c52b4 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Jul 2020 23:55:28 +0100 Subject: [PATCH 12/12] Bug fixes --- src/Ide/Plugin/Eval.hs | 29 +++++++++++++++++------------ test/functional/Eval.hs | 4 +++- test/testdata/eval/T6.hs | 9 +++++++++ test/testdata/eval/T6.hs.expected | 9 +++++++++ test/testdata/eval/T7.hs | 10 ++++++++++ test/testdata/eval/T7.hs.expected | 10 ++++++++++ 6 files changed, 58 insertions(+), 13 deletions(-) create mode 100644 test/testdata/eval/T6.hs create mode 100644 test/testdata/eval/T6.hs.expected create mode 100644 test/testdata/eval/T7.hs create mode 100644 test/testdata/eval/T7.hs.expected diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs index 8936079361..9b452ece61 100644 --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -81,6 +81,7 @@ import PrelNames (pRELUDE) import System.FilePath import System.IO (hClose) import System.IO.Temp +import Data.Maybe (catMaybes) descriptor :: PluginId -> PluginDescriptor descriptor plId = @@ -179,7 +180,10 @@ with all the dependencies. Unfortunately, the ModSummary objects that GhcSessionDeps puts in the GHC session are not suitable for reuse since they clear out the timestamps; this is done to avoid internal ghcide bugs and can probably be relaxed so that plugins like Eval can reuse them. Once that's -done, we want to switch back to GhcSessionDeps +done, we want to switch back to GhcSessionDeps: + +-- https://github.com/digital-asset/ghcide/pull/694 + -} session <- liftIO $ @@ -240,6 +244,7 @@ done, we want to switch back to GhcSessionDeps let eval (stmt, l) | isStmt df stmt = do -- set up a custom interactive print function + liftIO $ writeFile temp "" ctxt <- getContext setContext [IIDecl (simpleImportDecl $ moduleName pRELUDE)] let printFun = "let ghcideCustomShow x = Prelude.writeFile " <> show temp <> " (Prelude.show x)" @@ -256,29 +261,29 @@ done, we want to switch back to GhcSessionDeps execLineNumber = l } res <- execStmt stmt opts - str <- case res of - ExecComplete (Left err) _ -> pure $ pad $ show err + case res of + ExecComplete (Left err) _ -> return $ Just $ T.pack $ pad $ show err ExecComplete (Right _) _ -> do out <- liftIO $ pad <$> readFile temp - let forceIt = length out - return $! forceIt `seq` out - ExecBreak {} -> pure $ pad "breakpoints are not supported" + -- Important to take the length in order to read the file eagerly + return $! if length out == 0 then Nothing else Just (T.pack out) + ExecBreak {} -> return $ Just $ T.pack $ pad "breakpoints are not supported" - let changes = [TextEdit editTarget $ T.pack str] - return changes | isImport df stmt = do ctxt <- getContext idecl <- parseImportDecl stmt setContext $ IIDecl idecl : ctxt - return [] + return Nothing | otherwise = do void $ runDecls stmt - return [] + return Nothing edits <- liftIO $ evalGhcEnv hscEnv' $ traverse (eval . first T.unpack) statements - let workspaceEditsMap = Map.fromList [(_uri, List $ concat edits)] - let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing + + let workspaceEditsMap = Map.fromList [(_uri, List [evalEdit])] + workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing + evalEdit = TextEdit editTarget (T.intercalate "\n" $ catMaybes edits) return (WorkspaceApplyEdit, ApplyWorkspaceEditParams workspaceEdits) diff --git a/test/functional/Eval.hs b/test/functional/Eval.hs index 31108ec419..4f4cc91691 100644 --- a/test/functional/Eval.hs +++ b/test/functional/Eval.hs @@ -49,8 +49,10 @@ tests = testCase "Evaluation of expressions" $ goldenTest "T1.hs", testCase "Reevaluation of expressions" $ goldenTest "T2.hs", testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs", - testCase "Refresh an evaluation" $ goldenTest "T5.hs" testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs", + testCase "Refresh an evaluation" $ goldenTest "T5.hs", + testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs", + testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs" ] goldenTest :: FilePath -> IO () diff --git a/test/testdata/eval/T6.hs b/test/testdata/eval/T6.hs new file mode 100644 index 0000000000..e67aa21c13 --- /dev/null +++ b/test/testdata/eval/T6.hs @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/eval/T6.hs.expected b/test/testdata/eval/T6.hs.expected new file mode 100644 index 0000000000..9eb9c57cf1 --- /dev/null +++ b/test/testdata/eval/T6.hs.expected @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/eval/T7.hs b/test/testdata/eval/T7.hs new file mode 100644 index 0000000000..c74ac7de63 --- /dev/null +++ b/test/testdata/eval/T7.hs @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is a stale example of" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/eval/T7.hs.expected b/test/testdata/eval/T7.hs.expected new file mode 100644 index 0000000000..739c3db041 --- /dev/null +++ b/test/testdata/eval/T7.hs.expected @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is an example of" +example :: [String] +example = ["This","is","an","example","of"]