From ec969dab3b83117255f796c43f61d9de61384e89 Mon Sep 17 00:00:00 2001 From: Junyoung/Clare Jang Date: Fri, 21 Jan 2022 20:04:32 -0500 Subject: [PATCH 1/2] Add diff option for eval plugin --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 12 +- .../src/Ide/Plugin/Eval/Code.hs | 240 +++++++++--------- .../src/Ide/Plugin/Eval/CodeLens.hs | 22 +- .../src/Ide/Plugin/Eval/Config.hs | 21 ++ 5 files changed, 164 insertions(+), 132 deletions(-) create mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index a70c68b432..5d6b3dc78f 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -45,6 +45,7 @@ library other-modules: Ide.Plugin.Eval.Code Ide.Plugin.Eval.CodeLens + Ide.Plugin.Eval.Config Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Option diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index df2184c2fc..c223f522f1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -11,10 +11,13 @@ module Ide.Plugin.Eval ( import Development.IDE (IdeState) import qualified Ide.Plugin.Eval.CodeLens as CL +import Ide.Plugin.Eval.Config import Ide.Plugin.Eval.Rules (rules) -import Ide.Types (PluginDescriptor (..), PluginId, +import Ide.Types (ConfigDescriptor (..), + PluginDescriptor (..), PluginId, + defaultConfigDescriptor, defaultPluginDescriptor, - mkPluginHandler) + mkCustomConfig, mkPluginHandler) import Language.LSP.Types -- |Plugin descriptor @@ -22,6 +25,9 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens - , pluginCommands = [CL.evalCommand] + , pluginCommands = [CL.evalCommand plId] , pluginRules = rules + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties + } } 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 51311b3766..dd109f0b44 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -1,120 +1,120 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} - --- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where - -import Control.Lens ((^.)) -import Control.Monad.IO.Class -import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) -import qualified Data.List.NonEmpty as NE -import Data.String (IsString) -import qualified Data.Text as T -import Development.IDE.GHC.Compat -import Development.IDE.Types.Location (Position (..), Range (..)) -import GHC (ExecOptions, ExecResult (..), - execStmt) -import Ide.Plugin.Eval.Types (Language (Plain), Loc, - Located (..), - Section (sectionLanguage), - Test (..), Txt, locate, - locate0) -import Language.LSP.Types.Lens (line, start) -import System.IO.Extra (newTempFile, readFile') - --- | Return the ranges of the expression and result parts of the given test -testRanges :: Test -> (Range, Range) -testRanges tst = - let startLine = testRange tst ^. start.line - (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst - resLine = startLine + exprLines - in ( Range - (Position startLine 0) - --(Position (startLine + exprLines + resultLines) 0), - (Position resLine 0) - , Range (Position resLine 0) (Position (resLine + resultLines) 0) - ) - -{- |The document range where a test is defined - testRange :: Loc Test -> Range - testRange = fst . testRanges --} - --- |The document range where the result of the test is defined -resultRange :: Test -> Range -resultRange = snd . testRanges - --- TODO: handle BLANKLINE -{- ->>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] -["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] --} -showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] -showDiffs = map showDiff - -showDiff :: (Semigroup a, IsString a) => Diff a -> a -showDiff (First w) = "WAS " <> w -showDiff (Second w) = "NOW " <> w -showDiff (Both w _) = w - -testCheck :: (Section, Test) -> [T.Text] -> [T.Text] -testCheck (section, test) out - | null (testOutput test) || sectionLanguage section == Plain = out - | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out - -testLengths :: Test -> (Int, Int) -testLengths (Example e r _) = (NE.length e, length r) -testLengths (Property _ r _) = (1, length r) - --- |A one-line Haskell statement -type Statement = Loc String - -asStatements :: Test -> [Statement] -asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt) - -asStmts :: Test -> [Txt] -asStmts (Example e _ _) = NE.toList e -asStmts (Property t _ _) = - ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] - - --- |GHC declarations required for expression evaluation -evalSetup :: Ghc () -evalSetup = do - preludeAsP <- parseImportDecl "import qualified Prelude as P" - context <- getContext - setContext (IIDecl preludeAsP : context) - --- | 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 - -Example: - -prop> \(l::[Bool]) -> reverse (reverse l) == l -+++ OK, passed 100 tests. - -prop> \(l::[Bool]) -> reverse l == l -*** Failed! Falsified (after 6 tests and 2 shrinks): -[True,False] --} -propSetup :: [Loc [Char]] -propSetup = - locate0 - [ ":set -XScopedTypeVariables -XExplicitForAll" - , "import qualified Test.QuickCheck as Q11" - , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display - ] +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} + +-- | Expression execution +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class +import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) +import qualified Data.List.NonEmpty as NE +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import Development.IDE.Types.Location (Position (..), Range (..)) +import GHC (ExecOptions, ExecResult (..), + execStmt) +import Ide.Plugin.Eval.Types (Language (Plain), Loc, + Located (..), + Section (sectionLanguage), + Test (..), Txt, locate, + locate0) +import Language.LSP.Types.Lens (line, start) +import System.IO.Extra (newTempFile, readFile') + +-- | Return the ranges of the expression and result parts of the given test +testRanges :: Test -> (Range, Range) +testRanges tst = + let startLine = testRange tst ^. start.line + (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst + resLine = startLine + exprLines + in ( Range + (Position startLine 0) + --(Position (startLine + exprLines + resultLines) 0), + (Position resLine 0) + , Range (Position resLine 0) (Position (resLine + resultLines) 0) + ) + +{- |The document range where a test is defined + testRange :: Loc Test -> Range + testRange = fst . testRanges +-} + +-- |The document range where the result of the test is defined +resultRange :: Test -> Range +resultRange = snd . testRanges + +-- TODO: handle BLANKLINE +{- +>>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] +["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] +-} +showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] +showDiffs = map showDiff + +showDiff :: (Semigroup a, IsString a) => Diff a -> a +showDiff (First w) = "WAS " <> w +showDiff (Second w) = "NOW " <> w +showDiff (Both w _) = w + +testCheck :: Bool -> (Section, Test) -> [T.Text] -> [T.Text] +testCheck diff (section, test) out + | not diff || null (testOutput test) || sectionLanguage section == Plain = out + | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out + +testLengths :: Test -> (Int, Int) +testLengths (Example e r _) = (NE.length e, length r) +testLengths (Property _ r _) = (1, length r) + +-- |A one-line Haskell statement +type Statement = Loc String + +asStatements :: Test -> [Statement] +asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt) + +asStmts :: Test -> [Txt] +asStmts (Example e _ _) = NE.toList e +asStmts (Property t _ _) = + ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] + + +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) + +-- | 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 + +Example: + +prop> \(l::[Bool]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. + +prop> \(l::[Bool]) -> reverse l == l +*** Failed! Falsified (after 6 tests and 2 shrinks): +[True,False] +-} +propSetup :: [Loc [Char]] +propSetup = + locate0 + [ ":set -XScopedTypeVariables -XExplicitForAll" + , "import qualified Test.QuickCheck as Q11" + , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display + ] 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 4981349c82..978434a242 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -30,6 +30,7 @@ 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 (lift) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) import Data.Char (isSpace) @@ -78,10 +79,12 @@ import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Types.Shake (toKey) +import Ide.Plugin.Config (Config) import Ide.Plugin.Eval.Code (Statement, asStatements, evalSetup, myExecStmt, propSetup, resultRange, testCheck, testRanges) +import Ide.Plugin.Eval.Config (getDiffProperty) import Ide.Plugin.Eval.GHC (addImport, addPackages, hasPackage, showDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) @@ -176,16 +179,16 @@ codeLens st plId CodeLensParams{_textDocument} = evalCommandName :: CommandId evalCommandName = "evalCommand" -evalCommand :: PluginCommand IdeState -evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd +evalCommand :: PluginId -> PluginCommand IdeState +evalCommand plId = PluginCommand evalCommandName "evaluate" (runEvalCmd plId) type EvalId = Int -runEvalCmd :: CommandFunction IdeState EvalParams -runEvalCmd st EvalParams{..} = +runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams +runEvalCmd plId st EvalParams{..} = let dbg = logWith st perf = timed dbg - cmd :: ExceptT String (LspM c) WorkspaceEdit + cmd :: ExceptT String (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -300,12 +303,13 @@ runEvalCmd st EvalParams{..} = -- Evaluation takes place 'inside' the module setContext [Compat.IIModule modName] Right <$> getSession - + diff <- lift $ getDiffProperty plId edits <- perf "edits" $ liftIO $ evalGhcEnv hscEnv' $ runTests + diff (st, fp) tests @@ -347,8 +351,8 @@ testsBySection sections = type TEnv = (IdeState, String) -runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit] -runTests e@(_st, _) tests = do +runTests :: Bool -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] +runTests diff e@(_st, _) tests = do df <- getInteractiveDynFlags evalSetup when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup @@ -363,7 +367,7 @@ runTests e@(_st, _) tests = do rs <- runTest e df test dbg "TEST RESULTS" rs - let checkedResult = testCheck (section, test) rs + let checkedResult = testCheck diff (section, test) rs let edit = asEdit (sectionFormat section) test (map pad checkedResult) dbg "TEST EDIT" edit diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs new file mode 100644 index 0000000000..fc3dea26d4 --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +module Ide.Plugin.Eval.Config + ( properties + , getDiffProperty + ) where + +import Ide.Plugin.Config (Config) +import Ide.Plugin.Properties +import Ide.PluginUtils (usePropertyLsp) +import Ide.Types (PluginId) +import Language.LSP.Server (MonadLsp) + +properties :: Properties '[ 'PropertyKey "diff" 'TBoolean] +properties = emptyProperties + & defineBooleanProperty #diff + "Enable the diff output (WAS/NOW) of eval lenses" True + +getDiffProperty :: (MonadLsp Config m) => PluginId -> m Bool +getDiffProperty plId = usePropertyLsp #diff plId properties From 2fe4b85d887dc1043b056575c2f012612c852c59 Mon Sep 17 00:00:00 2001 From: Junyoung/Clare Jang Date: Mon, 24 Jan 2022 13:16:52 -0500 Subject: [PATCH 2/2] Add a test for the diff option --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 ++ plugins/hls-eval-plugin/test/Main.hs | 21 ++++++++++++++++++- .../test/testdata/TDiff.expected.default.hs | 8 +++++++ .../test/testdata/TDiff.expected.no-diff.hs | 7 +++++++ .../hls-eval-plugin/test/testdata/TDiff.hs | 7 +++++++ 5 files changed, 44 insertions(+), 1 deletion(-) create mode 100644 plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TDiff.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 5d6b3dc78f..d64bccb136 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -106,10 +106,12 @@ test-suite tests build-depends: , aeson , base + , containers , directory , extra , filepath , hls-eval-plugin + , hls-plugin-api , hls-test-utils ^>=1.1 , lens , lsp-types diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 6c69dbbaa7..7a9f46b980 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -9,11 +9,15 @@ module Main import Control.Lens (_Just, folded, preview, toListOf, view, (^..)) -import Data.Aeson (fromJSON) +import Data.Aeson (Value (Object), fromJSON, object, + toJSON, (.=)) import Data.Aeson.Types (Result (Success)) import Data.List (isInfixOf) import Data.List.Extra (nubOrdOn) +import qualified Data.Map as Map import qualified Data.Text as T +import Ide.Plugin.Config (Config) +import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) @@ -139,6 +143,11 @@ tests = , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs" , goldenWithEval "Variable 'it' works" "TIt" "hs" + , goldenWithHaskellDoc evalPlugin "Give 'WAS' by default" testDataDir "TDiff" "expected.default" "hs" executeLensesBackwards + , goldenWithHaskellDoc evalPlugin "Give the result only if diff is off" testDataDir "TDiff" "expected.no-diff" "hs" $ \doc -> do + sendConfigurationChanged (toJSON diffOffConfig) + executeLensesBackwards doc + , testGroup ":info command" [ testCase ":info reports type, constructors and instances" $ do [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs" @@ -242,6 +251,16 @@ codeLensTestOutput codeLens = do testDataDir :: FilePath testDataDir = "test" "testdata" +diffOffConfig :: Config +diffOffConfig = + def + { Plugin.plugins = Map.fromList [("eval", + def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object ["diff" .= False] } + )] } + where + unObject (Object obj) = obj + unObject _ = undefined + evalInFile :: FilePath -> T.Text -> T.Text -> IO () evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc fp "haskell" diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs new file mode 100644 index 0000000000..a2ed8fbd44 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.default.hs @@ -0,0 +1,8 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- WAS 4 +-- NOW 5 +myId :: a -> a +myId x = x diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs new file mode 100644 index 0000000000..373a64a804 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.expected.no-diff.hs @@ -0,0 +1,7 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- 5 +myId :: a -> a +myId x = x diff --git a/plugins/hls-eval-plugin/test/testdata/TDiff.hs b/plugins/hls-eval-plugin/test/testdata/TDiff.hs new file mode 100644 index 0000000000..bf5b0eb287 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TDiff.hs @@ -0,0 +1,7 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- 4 +myId :: a -> a +myId x = x