diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index 5ad4537338..61b3e8e2ba 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} -- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, evalExpr, propSetup, testCheck, asStatements) where +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) @@ -10,17 +11,20 @@ import qualified Data.List.NonEmpty as NE import Data.String (IsString) import qualified Data.Text as T import Development.IDE.Types.Location (Position (..), Range (..)) -import GHC (InteractiveImport (IIDecl), compileExpr) +import GHC (ExecOptions, ExecResult (..), + execStmt) import GHC.LanguageExtensions.Type (Extension (..)) -import GhcMonad (Ghc, GhcMonad, liftIO) +import GhcMonad (Ghc, liftIO, modifySession) +import HscTypes import Ide.Plugin.Eval.Types (Language (Plain), Loc, Located (..), Section (sectionLanguage), Test (..), Txt, locate, locate0) -import InteractiveEval (getContext, parseImportDecl, runDecls, setContext) +import InteractiveEval (getContext, parseImportDecl, + runDecls, setContext) import Language.LSP.Types.Lens (line, start) -import Unsafe.Coerce (unsafeCoerce) +import System.IO.Extra (newTempFile, readFile') -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range) @@ -77,12 +81,6 @@ asStmts (Example e _ _) = NE.toList e asStmts (Property t _ _) = ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] --- |Evaluate an expression (either a pure expression or an IO a) -evalExpr :: GhcMonad m => [Char] -> m String -evalExpr e = do - res <- compileExpr $ "asPrint (" ++ e ++ ")" - liftIO (unsafeCoerce res :: IO String) - -- |GHC extensions required for expression evaluation evalExtensions :: [Extension] evalExtensions = @@ -99,12 +97,19 @@ evalSetup = do preludeAsP <- parseImportDecl "import qualified Prelude as P" context <- getContext setContext (IIDecl preludeAsP : context) - mapM_ - runDecls - [ "class Print f where asPrint :: f -> P.IO P.String" - , "instance P.Show a => Print (P.IO a) where asPrint io = io P.>>= P.return P.. P.show" - , "instance P.Show a => Print a where asPrint a = P.return (P.show a)" - ] + +-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result +myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) +myExecStmt stmt opts = do + (temp, purge) <- liftIO newTempFile + evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") + modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} + result <- execStmt stmt opts >>= \case + ExecComplete (Left err) _ -> pure $ Left $ show err + ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp + ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported" + liftIO purge + pure result {- |GHC declarations required to execute test properties diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 3ffa267a3a..76a968cf39 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {- | @@ -23,166 +23,123 @@ module Ide.Plugin.Eval.CodeLens ( evalCommand, ) where -import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (second, (>>>)) -import qualified Control.Exception as E -import Control.Monad - ( void, - when, guard, - join - ) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except - ( ExceptT (..), - ) -import Data.Aeson (toJSON) -import Data.Char (isSpace) -import qualified Data.HashMap.Strict as HashMap -import Data.List - (dropWhileEnd, - find, intercalate - ) -import qualified Data.Map.Strict as Map -import Data.Maybe - ( catMaybes, - fromMaybe, - ) -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (getCurrentTime) -import Data.Typeable (Typeable) -import Development.IDE - ( Action, - realSrcSpanToRange, GetModSummary (..), - GetParsedModuleWithComments (..), - HscEnvEq, - IdeState, - evalGhcEnv, - hscEnvWithImportPaths, - runAction, - textToStringBuffer, - toNormalizedFilePath', - uriToFilePath', - useWithStale_, - prettyPrint, - use_, useNoFile_, uses_, - GhcSessionIO(..), GetDependencies(..), GetModIface(..), - HiFileResult (hirHomeMod, hirModSummary), - ModSummaryResult(..) - ) -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 - (ExecOptions - ( execLineNumber, - execSourceFile - ), - ExecResult (..), - GeneralFlag (..), - Ghc, - GhcLink (LinkInMemory), - GhcMode (CompManager), - GhcMonad (getSession), - HscTarget (HscInterpreted), - LoadHowMuch (LoadAllTargets), - ModSummary (ms_hspp_opts), - Module (moduleName), - SuccessFlag (Failed, Succeeded), - TcRnExprMode (..), - execOptions, - execStmt, - exprType, - getInteractiveDynFlags, - getSessionDynFlags, - isImport, - isStmt, - load, - runDecls, - setContext, - setLogAction, - setSessionDynFlags, - setTargets, - typeKind, - ) -import GhcPlugins - ( DynFlags (..), - hsc_dflags, - defaultLogActionHPutStrDoc, - gopt_set, - gopt_unset, - interpWays, - targetPlatform, - updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags, - xopt_set, parseDynamicFlagsCmdLine - ) -import HscTypes - ( InteractiveImport (IIModule), - ModSummary (ms_mod), - Target (Target), - TargetId (TargetFile), - ) -import Ide.Plugin.Eval.Code - ( Statement, - asStatements, - evalExpr, - evalExtensions, - evalSetup, - propSetup, - resultRange, - testCheck, - testRanges, - ) -import Ide.Plugin.Eval.GHC - ( addImport, - addPackages, - hasPackage, - isExpr, - showDynFlags, - ) -import Ide.Plugin.Eval.Parse.Comments (commentsToSections) -import Ide.Plugin.Eval.Parse.Option (parseSetFlags) -import Ide.Plugin.Eval.Types -import Ide.Plugin.Eval.Util - ( asS, - gStrictTry, - handleMaybe, - handleMaybeM, - isLiterate, - logWith, - response, - response', - timed, - ) -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Language.LSP.VFS (virtualFileText) -import Outputable - ( nest, - ppr, - showSDoc, - text, - ($$), - (<+>), - ) -import System.FilePath (takeFileName) -import System.IO (hClose) -import UnliftIO.Temporary (withSystemTempFile) -import Util (OverridingBool (Never)) -import Development.IDE.Core.PositionMapping (toCurrentRange) -import qualified Data.DList as DL -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) +import CmdLineParser +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (second, (>>>)) +import Control.Exception (try) +import qualified Control.Exception as E +import Control.Lens (_1, _3, (%~), (<&>), + (^.)) +import Control.Monad (guard, join, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Aeson (toJSON) +import Data.Char (isSpace) +import qualified Data.DList as DL +import qualified Data.HashMap.Strict as HashMap +import Data.List (dropWhileEnd, find, + intercalate) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Data.Typeable (Typeable) +import Development.IDE (Action, + GetDependencies (..), + GetModIface (..), + GetModSummary (..), + GetParsedModuleWithComments (..), + GhcSessionIO (..), + HiFileResult (hirHomeMod, hirModSummary), + HscEnvEq, IdeState, + ModSummaryResult (..), + evalGhcEnv, + hscEnvWithImportPaths, + prettyPrint, + realSrcSpanToRange, + runAction, + textToStringBuffer, + toNormalizedFilePath', + uriToFilePath', + useNoFile_, + useWithStale_, use_, + uses_) +import Development.IDE.Core.Compile (loadModulesHome, + setupFinderCache) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps)) +import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), + GenLocated (L), + GhcException, HscEnv, + ParsedModule (..), + SrcSpan (RealSrcSpan, UnhelpfulSpan), + setInteractiveDynFlags, + srcSpanFile) +import qualified Development.IDE.GHC.Compat as SrcLoc +import Development.IDE.Types.Options +import DynamicLoading (initializePlugins) +import FastString (unpackFS) +import GHC (ExecOptions (execLineNumber, execSourceFile), + GeneralFlag (..), Ghc, + GhcLink (LinkInMemory), + GhcMode (CompManager), + GhcMonad (getSession), + HscTarget (HscInterpreted), + LoadHowMuch (LoadAllTargets), + ModSummary (ms_hspp_opts), + Module (moduleName), + SuccessFlag (Failed, Succeeded), + TcRnExprMode (..), + execOptions, exprType, + getInteractiveDynFlags, + getSessionDynFlags, + isImport, isStmt, load, + runDecls, setContext, + setLogAction, + setSessionDynFlags, + setTargets, typeKind) +import GhcPlugins (DynFlags (..), + defaultLogActionHPutStrDoc, + gopt_set, gopt_unset, + hsc_dflags, interpWays, + parseDynamicFlagsCmdLine, + targetPlatform, + updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags, + xopt_set) +import HscTypes (InteractiveImport (IIModule), + ModSummary (ms_mod), + Target (Target), + TargetId (TargetFile)) +import Ide.Plugin.Eval.Code (Statement, asStatements, + evalExtensions, + evalSetup, myExecStmt, + propSetup, resultRange, + testCheck, testRanges) +import Ide.Plugin.Eval.GHC (addImport, addPackages, + hasPackage, showDynFlags) +import Ide.Plugin.Eval.Parse.Comments (commentsToSections) +import Ide.Plugin.Eval.Parse.Option (parseSetFlags) +import Ide.Plugin.Eval.Types +import Ide.Plugin.Eval.Util (asS, gStrictTry, + handleMaybe, + handleMaybeM, isLiterate, + logWith, response, + response', timed) +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Lens (end, line) +import Language.LSP.VFS (virtualFileText) +import Outputable (nest, ppr, showSDoc, + text, ($$), (<+>)) +import System.FilePath (takeFileName) +import System.IO (hClose) +import UnliftIO.Temporary (withSystemTempFile) +import Util (OverridingBool (Never)) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -224,9 +181,9 @@ codeLens st plId CodeLensParams{_textDocument} = foldMap (foldMap $ \(L a b) -> case b of - AnnLineComment{} -> mempty + AnnLineComment{} -> mempty AnnBlockComment{} -> mempty - _ -> DL.singleton (a, b) + _ -> DL.singleton (a, b) ) $ snd pm_annotations dbg "comments" $ show comments @@ -555,27 +512,14 @@ evals (st, fp) df stmts = do | -- A type/kind command Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = evalGhciLikeCmd cmd arg - | -- An expression - isExpr df stmt = - do - dbg "{EXPR" stmt - eres <- gStrictTry $ evalExpr stmt - dbg "RES ->" eres - let res = case eres of - Left err -> errorLines err - Right rs -> [T.pack rs] - dbg "EXPR} ->" res - return . Just $ res | -- A statement isStmt df stmt = do dbg "{STMT " stmt res <- exec stmt l r <- case res of - ExecComplete (Left err) _ -> return . Just . errorLines . show $ err - ExecComplete (Right _) _ -> return Nothing - ExecBreak{} -> - return . Just . singleLine $ "breakpoints are not supported" + Left err -> return . Just . errorLines $ err + Right x -> return $ singleLine <$> x dbg "STMT} -> " r return r | -- An import @@ -592,7 +536,7 @@ evals (st, fp) df stmts = do return Nothing exec stmt l = let opts = execOptions{execSourceFile = fp, execLineNumber = l} - in execStmt stmt opts + in myExecStmt stmt opts prettyWarn :: Warn -> String prettyWarn Warn{..} = @@ -638,8 +582,7 @@ singleLine s = [T.pack s] -} errorLines :: String -> [Text] errorLines = - map (\e -> fromMaybe e (T.stripSuffix "arising from a use of ‘asPrint’" e)) - . dropWhileEnd T.null + dropWhileEnd T.null . takeWhile (not . ("CallStack" `T.isPrefixOf`)) . T.lines . T.pack @@ -658,7 +601,7 @@ convertBlank x padPrefix :: IsString p => Format -> p padPrefix SingleLine = "-- " -padPrefix _ = "" +padPrefix _ = "" {- | Resulting @Text@ MUST NOT prefix each line with @--@ Such comment-related post-process will be taken place @@ -716,11 +659,11 @@ parseExprMode :: Text -> (TcRnExprMode, T.Text) parseExprMode rawArg = case T.break isSpace rawArg of ("+v", rest) -> (TM_NoInst, T.strip rest) ("+d", rest) -> (TM_Default, T.strip rest) - _ -> (TM_Inst, rawArg) + _ -> (TM_Inst, rawArg) data GhciLikeCmdException = GhciLikeCmdNotImplemented { ghciCmdName :: Text - , ghciCmdArg :: Text + , ghciCmdArg :: Text } deriving (Typeable) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs index 0f65bfb232..5a0349f0ba 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -5,7 +5,6 @@ -- |GHC API utilities module Ide.Plugin.Eval.GHC ( - isExpr, addExtension, addImport, hasPackage, @@ -42,33 +41,6 @@ import StringBuffer (stringToStringBuffer) "/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4" -} -{- | Returns true if string is an expression - ->>> isExprTst e df = return (isExpr df e) ->>> run $ isExprTst "3" -True - ->>> run $ isExprTst "(x+y)" -True - ->>> run $ isExprTst "import Data.Maybe" -False - ->>> run $ isExprTst "three=3" -False --} -isExpr :: DynFlags -> String -> Bool -isExpr df stmt = case parseThing Parser.parseExpression df stmt of - Lexer.POk _ _ -> True - Lexer.PFailed{} -> False - -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit "") 1 1 - - Lexer.unP parser (Lexer.mkPState dflags buf loc) - {- | True if specified package is present in DynFlags -- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg) diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs index 06b50af087..bd48214c0d 100644 --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -157,6 +157,8 @@ tests = ] , testCase "Works with NoImplicitPrelude" $ goldenTest "TNoImplicitPrelude.hs" + , testCase "Variable 'it' works" + $ goldenTest "TIt.hs" ] goldenTest :: FilePath -> IO () diff --git a/plugins/hls-eval-plugin/test/testdata/TIt.hs b/plugins/hls-eval-plugin/test/testdata/TIt.hs new file mode 100644 index 0000000000..9430fbe477 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIt.hs @@ -0,0 +1,7 @@ +module TIt where + +-- >>> "test" +-- >>> it + +-- >>> pure "test2" +-- >>> it diff --git a/plugins/hls-eval-plugin/test/testdata/TIt.hs.expected b/plugins/hls-eval-plugin/test/testdata/TIt.hs.expected new file mode 100644 index 0000000000..940fb1a23d --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TIt.hs.expected @@ -0,0 +1,11 @@ +module TIt where + +-- >>> "test" +-- >>> it +-- "test" +-- "test" + +-- >>> pure "test2" +-- >>> it +-- "test2" +-- "test2"