hls-eval-plugin 1.2.1.0 → 1.2.2.0
raw patch · 33 files changed
+1184/−831 lines, 33 filesdep −temporarydep ~ghcdep ~ghcidedep ~hls-plugin-apinew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: temporary
Dependency ranges changed: ghc, ghcide, hls-plugin-api, hls-test-utils, parser-combinators
API changes (from Hackage documentation)
+ Ide.Plugin.Eval: LogEvalRules :: Log -> Log
+ Ide.Plugin.Eval: instance GHC.Show.Show Ide.Plugin.Eval.Log
+ Ide.Plugin.Eval: instance Prettyprinter.Internal.Pretty Ide.Plugin.Eval.Log
+ Ide.Plugin.Eval: newtype Log
- Ide.Plugin.Eval: descriptor :: PluginId -> PluginDescriptor IdeState
+ Ide.Plugin.Eval: descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
Files
- README.md +25/−0
- hls-eval-plugin.cabal +7/−5
- src/Ide/Plugin/Eval.hs +28/−11
- src/Ide/Plugin/Eval/Code.hs +120/−120
- src/Ide/Plugin/Eval/CodeLens.hs +60/−51
- src/Ide/Plugin/Eval/Config.hs +37/−0
- src/Ide/Plugin/Eval/GHC.hs +5/−3
- src/Ide/Plugin/Eval/Parse/Comments.hs +572/−572
- src/Ide/Plugin/Eval/Rules.hs +53/−18
- src/Ide/Plugin/Eval/Util.hs +0/−6
- test/Main.hs +69/−25
- test/info-util/InfoUtil.hs +20/−20
- test/testdata/T10.ghc92.expected.hs +11/−0
- test/testdata/T11.ghc92.expected.hs +4/−0
- test/testdata/T11.ghc92_expected.hs +4/−0
- test/testdata/T12.ghc92.expected.hs +10/−0
- test/testdata/T12.ghc92_expected.hs +10/−0
- test/testdata/T13.ghc92.expected.hs +4/−0
- test/testdata/T13.ghc92_expected.hs +4/−0
- test/testdata/T15.ghc92_expected.hs +8/−0
- test/testdata/T17.ghc92.expected.hs +4/−0
- test/testdata/T17.ghc92_expected.hs +4/−0
- test/testdata/T20.ghc92.expected.hs +7/−0
- test/testdata/T20.ghc92_expected.hs +7/−0
- test/testdata/TDiff.expected.default.hs +8/−0
- test/testdata/TDiff.expected.no-diff.hs +7/−0
- test/testdata/TDiff.hs +7/−0
- test/testdata/TException.expected.marked.hs +6/−0
- test/testdata/TException.expected.nomark.hs +6/−0
- test/testdata/TException.hs +5/−0
- test/testdata/TFlags.ghc92.expected.hs +62/−0
- test/testdata/TPropertyError.expected.hs +6/−0
- test/testdata/TPropertyError.hs +4/−0
README.md view
@@ -242,6 +242,11 @@ -} ``` +If you find this WAS/NOW behaviour does not fit your needs, you can turn it off with toggling the configuration option:+```json+"haskell.plugin.eval.config.diff": false+```+ # Multiline Output By default, the output of every expression is returned as a single line.@@ -274,6 +279,8 @@ ] ``` +This assumes you did not turn on exception marking (see [Marking exceptions](#marking-exceptions) below).+ # Differences with doctest Though the Eval plugin functionality is quite similar to that of [doctest](https://hackage.haskell.org/package/doctest), some doctest's features are not supported.@@ -285,6 +292,24 @@ ``` >>> print "foo" ()+```++### Marking exceptions++When an exception is thrown it is not prefixed:++```+>>> 1 `div` 0+divide by zero+```++If you want to get the doctest/GHCi behaviour, you can toggle the configuration option:+```json+"haskell.plugin.eval.config.exception": true+```+```+>>> 1 `div` 0+*** Exception: divide by zero ``` ### Pattern Matching
hls-eval-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin-version: 1.2.1.0+version: 1.2.2.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -45,6 +45,7 @@ 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@@ -65,10 +66,10 @@ , ghc , ghc-boot-th , ghc-paths- , ghcide ^>=1.6+ , ghcide ^>=1.7 , hashable , hls-graph- , hls-plugin-api ^>=1.3+ , hls-plugin-api ^>=1.4 , lens , lsp , lsp-types@@ -78,7 +79,6 @@ , pretty-simple , QuickCheck , safe-exceptions- , temporary , text , time , transformers@@ -105,11 +105,13 @@ build-depends: , aeson , base+ , containers , directory , extra , filepath , hls-eval-plugin- , hls-test-utils ^>=1.2+ , hls-plugin-api+ , hls-test-utils ^>=1.3 , lens , lsp-types , text
src/Ide/Plugin/Eval.hs view
@@ -1,27 +1,44 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE LambdaCase #-} {- | Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor,-) where+ Log(..)+ ) where -import Development.IDE (IdeState)-import qualified Ide.Plugin.Eval.CodeLens as CL-import Ide.Plugin.Eval.Rules (rules)-import Ide.Types (PluginDescriptor (..), PluginId,- defaultPluginDescriptor,- mkPluginHandler)+import Development.IDE (IdeState)+import Development.IDE.Types.Logger (Pretty (pretty), Recorder,+ WithPriority, cmapWithPrio)+import qualified Ide.Plugin.Eval.CodeLens as CL+import Ide.Plugin.Eval.Config+import Ide.Plugin.Eval.Rules (rules)+import qualified Ide.Plugin.Eval.Rules as EvalRules+import Ide.Types (ConfigDescriptor (..),+ PluginDescriptor (..), PluginId,+ defaultConfigDescriptor,+ defaultPluginDescriptor,+ mkCustomConfig, mkPluginHandler) import Language.LSP.Types +newtype Log = LogEvalRules EvalRules.Log deriving Show++instance Pretty Log where+ pretty = \case+ LogEvalRules log -> pretty log+ -- |Plugin descriptor-descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId =+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens- , pluginCommands = [CL.evalCommand]- , pluginRules = rules+ , pluginCommands = [CL.evalCommand plId]+ , pluginRules = rules (cmapWithPrio LogEvalRules recorder)+ , pluginConfigDescriptor = defaultConfigDescriptor+ { configCustomConfig = mkCustomConfig properties+ } }
src/Ide/Plugin/Eval/Code.hs view
@@ -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+ ]
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -27,9 +27,10 @@ import Control.Arrow (second, (>>>)) import Control.Exception (try) import qualified Control.Exception as E-import Control.Lens (_1, _3, (%~), (<&>), (^.))+import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) 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)@@ -49,11 +50,12 @@ NeedsCompilation (NeedsCompilation), evalGhcEnv, hscEnvWithImportPaths,- prettyPrint, runAction,+ printOutputable, runAction, textToStringBuffer, toNormalizedFilePath', uriToFilePath', useNoFile_,- useWithStale_, use_)+ useWithStale_, use_,+ VFSModified(..)) import Development.IDE.Core.Rules (GhcSessionDepsConfig (..), ghcSessionDepsDefinition) import Development.IDE.GHC.Compat hiding (typeKind, unitState)@@ -72,23 +74,31 @@ getInteractiveDynFlags, isImport, isStmt, load, parseName, pprFamInst,- pprInstance, setLogAction,- setTargets, typeKind)+ pprInstance, setTargets,+ typeKind)+#if MIN_VERSION_ghc(9,2,0)+import GHC (Fixity)+#endif 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)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))+#endif import Ide.Plugin.Eval.Code (Statement, asStatements, evalSetup, myExecStmt, propSetup, resultRange, testCheck, testRanges)+import Ide.Plugin.Eval.Config (getEvalConfig, EvalConfig(..)) 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.Rules (queueForEvaluation) import Ide.Plugin.Eval.Types-import Ide.Plugin.Eval.Util (asS, gStrictTry, isLiterate,+import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, logWith, response', timed) import Ide.PluginUtils (handleMaybe, handleMaybeM, response)@@ -99,11 +109,9 @@ SemanticTokenRelative (length)) import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText)-import System.FilePath (takeFileName)-import System.IO (hClose)-import UnliftIO.Temporary (withSystemTempFile) -#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+#elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Session (unitDatabases, unitState) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else@@ -176,16 +184,16 @@ 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 @@ -196,7 +204,7 @@ -- enable codegen liftIO $ queueForEvaluation st nfp- liftIO $ setSomethingModified st [toKey NeedsCompilation nfp] "Eval"+ liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval" session <- runGetSession st nfp @@ -215,7 +223,7 @@ (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation- hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do+ hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do env <- getSession -- Install the module pragmas and options@@ -244,13 +252,8 @@ $ idflags setInteractiveDynFlags $ df' #if MIN_VERSION_ghc(9,0,0)- { unitState =- unitState- df- , unitDatabases =- unitDatabases- df- , packageFlags =+ {+ packageFlags = packageFlags df , useColor = Never@@ -271,15 +274,6 @@ } #endif - -- set up a custom log action-#if MIN_VERSION_ghc(9,0,0)- setLogAction $ \_df _wr _sev _span _doc ->- defaultLogActionHPutStrDoc _df logHandle _doc-#else- setLogAction $ \_df _wr _sev _span _style _doc ->- defaultLogActionHPutStrDoc _df logHandle _doc _style-#endif- -- Load the module with its current content (as the saved module might not be up to date) -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066@@ -289,23 +283,23 @@ -- load the module in the interactive environment loadResult <- perf "loadModule" $ load LoadAllTargets- dbg "LOAD RESULT" $ asS loadResult+ dbg "LOAD RESULT" $ printOutputable loadResult case loadResult of Failed -> liftIO $ do- hClose logHandle- err <- readFile logFilename+ let err = "" dbg "load ERR" err return $ Left err Succeeded -> do -- Evaluation takes place 'inside' the module setContext [Compat.IIModule modName] Right <$> getSession-+ evalCfg <- lift $ getEvalConfig plId edits <- perf "edits" $ liftIO $ evalGhcEnv hscEnv' $ runTests+ evalCfg (st, fp) tests @@ -347,11 +341,11 @@ type TEnv = (IdeState, String) -runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit]-runTests e@(_st, _) tests = do+runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]+runTests EvalConfig{..} e@(_st, _) tests = do df <- getInteractiveDynFlags evalSetup- when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup+ when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup mapM (processTest e df) tests where@@ -363,7 +357,7 @@ rs <- runTest e df test dbg "TEST RESULTS" rs - let checkedResult = testCheck (section, test) rs+ let checkedResult = testCheck eval_cfg_diff (section, test) rs let edit = asEdit (sectionFormat section) test (map pad checkedResult) dbg "TEST EDIT" edit@@ -375,7 +369,7 @@ return $ singleLine "Add QuickCheck to your cabal dependencies to run this test."- runTest e df test = evals e df (asStatements test)+ runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test) asEdit :: Format -> Test -> [Text] -> TextEdit asEdit (MultiLine commRange) test resultLines@@ -426,15 +420,19 @@ A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code: >>>:set -XNonExistent-Unknown extension: "NonExistent"+Some flags have not been recognized: -XNonExistent >>> cls C-Variable not in scope: cls :: t0 -> ()+Variable not in scope: cls :: t0 -> t Data constructor not in scope: C >>> "A lexical error in string/character literal at end of input +Exceptions are shown as if printed, but it can be configured to include prefix like+in GHCi or doctest. This allows it to be used as a hack to simulate print until we+get proper IO support. See #1977+ >>> 3 `div` 0 divide by zero @@ -445,10 +443,10 @@ Or for a value that does not have a Show instance and can therefore not be displayed: >>> data V = V >>> V-No instance for (Show V)+No instance for (Show V) arising from a use of ‘evalPrint’ -}-evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]-evals (st, fp) df stmts = do+evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]+evals mark_exception (st, fp) df stmts = do er <- gStrictTry $ mapM eval stmts return $ case er of Left err -> errorLines err@@ -495,9 +493,9 @@ do dbg "{STMT " stmt res <- exec stmt l- r <- case res of- Left err -> return . Just . errorLines $ err- Right x -> return $ singleLine <$> x+ let r = case res of+ Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err+ Right x -> singleLine <$> x dbg "STMT} -> " r return r | -- An import@@ -524,7 +522,7 @@ prettyWarn :: Warn -> String prettyWarn Warn{..} =- prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n"+ T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv@@ -564,6 +562,15 @@ . T.pack {- |+ Convert exception messages to a list of text lines+ Remove unnecessary information and mark it as exception.+ We use '*** Exception:' to make it identical to doctest+ output, see #2353.+-}+exceptionLines :: String -> [Text]+exceptionLines = (ix 0 %~ ("*** Exception: " <>)) . errorLines++{- | >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) ["--2+2","--<BLANKLINE>"] -}@@ -683,7 +690,9 @@ parseExprMode :: Text -> (TcRnExprMode, T.Text) parseExprMode rawArg = case T.break isSpace rawArg of+#if !MIN_VERSION_ghc(9,2,0) ("+v", rest) -> (TM_NoInst, T.strip rest)+#endif ("+d", rest) -> (TM_Default, T.strip rest) _ -> (TM_Inst, rawArg)
+ src/Ide/Plugin/Eval/Config.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+module Ide.Plugin.Eval.Config+ ( properties+ , getEvalConfig+ , EvalConfig(..)+ ) where++import Ide.Plugin.Config (Config)+import Ide.Plugin.Properties+import Ide.PluginUtils (usePropertyLsp)+import Ide.Types (PluginId)+import Language.LSP.Server (MonadLsp)++-- | The Eval plugin configuration. (see 'properties')+data EvalConfig = EvalConfig+ { eval_cfg_diff :: Bool+ , eval_cfg_exception :: Bool+ }+ deriving (Eq, Ord, Show)++properties :: Properties+ '[ 'PropertyKey "exception" 'TBoolean+ , 'PropertyKey "diff" 'TBoolean+ ]+properties = emptyProperties+ & defineBooleanProperty #diff+ "Enable the diff output (WAS/NOW) of eval lenses" True+ & defineBooleanProperty #exception+ "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi." False++getEvalConfig :: (MonadLsp Config m) => PluginId -> m EvalConfig+getEvalConfig plId =+ EvalConfig+ <$> usePropertyLsp #diff plId properties+ <*> usePropertyLsp #exception plId properties
src/Ide/Plugin/Eval/GHC.hs view
@@ -16,12 +16,14 @@ import Data.List (isPrefixOf) import Data.Maybe (mapMaybe) import Data.String (fromString)+import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import qualified Development.IDE.GHC.Compat.Util as EnumSet+import Development.IDE.GHC.Util (printOutputable) import GHC.LanguageExtensions.Type (Extension (..))-import Ide.Plugin.Eval.Util (asS, gStrictTry)+import Ide.Plugin.Eval.Util (gStrictTry) {- $setup >>> import GHC@@ -66,7 +68,7 @@ mapMaybe ( \case ExposePackage _ (PackageArg n) _ -> Just n- ExposePackage _ (UnitIdArg uid) _ -> Just $ asS uid+ ExposePackage _ (UnitIdArg uid) _ -> Just $ T.unpack $ printOutputable uid _ -> Nothing ) @@ -147,7 +149,7 @@ -- Partial display of DynFlags contents, for testing purposes showDynFlags :: DynFlags -> String showDynFlags df =- showSDocUnsafe . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $+ T.unpack . printOutputable . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $ [ ("extensions", ppr . extensions $ df) , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df) , ("importPaths", vList $ importPaths df)
src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -1,572 +1,572 @@-{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Ide.Plugin.Eval.Parse.Comments where - -import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Arrow (first, (&&&), (>>>)) -import Control.Lens (lensField, lensRules, - view, (.~), (^.)) -import Control.Lens.Extras (is) -import Control.Lens.TH (makeLensesWith, - makePrisms, - mappingNamer) -import Control.Monad (guard, void, when) -import Control.Monad.Combinators () -import Control.Monad.Reader (ask) -import Control.Monad.Trans.Reader (Reader, runReader) -import qualified Data.Char as C -import qualified Data.DList as DL -import qualified Data.Foldable as F -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Data.Void (Void) -import Development.IDE (Position, - Range (Range)) -import Development.IDE.Types.Location (Position (..)) -import GHC.Generics hiding (UInt, to) -import Ide.Plugin.Eval.Types -import Language.LSP.Types (UInt) -import Language.LSP.Types.Lens (character, end, line, - start) -import Text.Megaparsec -import qualified Text.Megaparsec as P -import Text.Megaparsec.Char (alphaNumChar, char, - eol, hspace, - letterChar) - -{- -We build parsers combining the following three kinds of them: - - * Line parser - paring a single line into an input, - works both for line- and block-comments. - A line should be a proper content of lines contained in comment: - doesn't include starting @--@ and @{\-@ and no ending @-\}@ - - * Line comment group parser: parses a contiguous group of - tuples of position and line comment into sections of line comments. - Each input MUST start with @--@. - - * Block comment parser: Parsing entire block comment into sections. - Input must be surrounded by @{\-@ and @-\}@. --} - --- | Line parser -type LineParser a = forall m. Monad m => ParsecT Void String m a - --- | Line comment group parser -type LineGroupParser = Parsec Void [(Range, RawLineComment)] - -data BlockEnv = BlockEnv - { isLhs :: Bool - , blockRange :: Range - } - deriving (Read, Show, Eq, Ord) - -makeLensesWith - (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) - ''BlockEnv - --- | Block comment parser -type BlockCommentParser = ParsecT Void String (Reader BlockEnv) - --- | Prop line, with "prop>" stripped off -newtype PropLine = PropLine {getPropLine :: String} - deriving (Show) - --- | Example line, with @>>>@ stripped off -newtype ExampleLine = ExampleLine {getExampleLine :: String} - deriving (Show) - -data TestComment - = AProp - { testCommentRange :: Range - , lineProp :: PropLine - , propResults :: [String] - } - | AnExample - { testCommentRange :: Range - , lineExamples :: NonEmpty ExampleLine - , exampleResults :: [String] - } - deriving (Show) - --- | Classification of comments -data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String - deriving (Read, Show, Eq, Ord) - --- | Single line or block comments? -data CommentStyle = Line | Block Range - deriving (Read, Show, Eq, Ord, Generic) - -makePrisms ''CommentStyle - -commentsToSections :: - -- | True if it is literate Haskell - Bool -> - Comments -> - Sections -commentsToSections isLHS Comments {..} = - let (lineSectionSeeds, lineSetupSeeds) = - foldMap - ( \lcs -> - let theRan = - Range - (view start $ fst $ NE.head lcs) - (view end $ fst $ NE.last lcs) - in case parseMaybe lineGroupP $ NE.toList lcs of - Nothing -> mempty - Just (mls, rs) -> - ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) - , -- orders setup sections in ascending order - if null rs - then mempty - else - Map.singleton theRan $ - DL.singleton (Line, rs) - ) - ) - $ groupLineComments $ - Map.filterWithKey - -- FIXME: - -- To comply with the initial behaviour of - -- Extended Eval Plugin; - -- but it also rejects modules with - -- non-zero base indentation level! - ( \pos _ -> - if isLHS - then pos ^. start . character == 2 - else pos ^. start . character == 0 - ) - lineComments - (blockSeed, blockSetupSeeds) = - foldMap - ( \(ran, lcs) -> - case parseBlockMaybe isLHS ran blockCommentBP $ - getRawBlockComment lcs of - Nothing -> mempty - Just (Named "setup", grp) -> - -- orders setup sections in ascending order - ( mempty - , Map.singleton ran $ - DL.singleton (Block ran, grp) - ) - Just grp -> - ( Map.singleton ran grp - , mempty - ) - ) - -- It seems Extended Eval Plugin doesn't constraint - -- starting indentation level for block comments. - -- Rather, it constrains the indentation level /inside/ - -- block comment body. - $ Map.toList blockComments - lineSections = - lineSectionSeeds <&> uncurry (testsToSection Line) - multilineSections = - Map.mapWithKey - (uncurry . testsToSection . Block) - blockSeed - setupSections = - -- Setups doesn't need Dummy position - map - ( \(style, tests) -> - testsToSection - style - (Named "setup") - tests - ) - $ DL.toList $ - F.fold $ - Map.unionWith (<>) lineSetupSeeds blockSetupSeeds - nonSetupSections = F.toList $ lineSections `Map.union` multilineSections - in Sections {..} - -parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a -parseBlockMaybe isLhs blockRange p i = - case runReader (runParserT p' "" i) BlockEnv {..} of - Left {} -> Nothing - Right a -> Just a - where - p' = do - updateParserState $ \st -> - st - { statePosState = - (statePosState st) - { pstateSourcePos = positionToSourcePos $ blockRange ^. start - } - } - p - -type CommentRange = Range - -type SectionRange = Range - -testsToSection :: - CommentStyle -> - CommentFlavour -> - [TestComment] -> - Section -testsToSection style flav tests = - let sectionName - | Named name <- flav = name - | otherwise = "" - sectionLanguage = case flav of - HaddockNext -> Haddock - HaddockPrev -> Haddock - _ -> Plain - sectionTests = map fromTestComment tests - sectionFormat = - case style of - Line -> SingleLine - Block ran -> MultiLine ran - in Section {..} - -fromTestComment :: TestComment -> Test -fromTestComment AProp {..} = - Property - { testline = getPropLine lineProp - , testOutput = propResults - , testRange = testCommentRange - } -fromTestComment AnExample {..} = - Example - { testLines = getExampleLine <$> lineExamples - , testOutput = exampleResults - , testRange = testCommentRange - } - --- * Block comment parser - -{- $setup ->>> dummyPos = Position 0 0 ->>> parseE p = either (error . errorBundlePretty) id . parse p "" --} - --- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" --- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) - -blockCommentBP :: - -- | True if Literate Haskell - BlockCommentParser (CommentFlavour, [TestComment]) -blockCommentBP = do - skipCount 2 anySingle -- "{-" - void $ optional $ char ' ' - flav <- commentFlavourP - hit <- skipNormalCommentBlock - if hit - then do - body <- - many $ - (blockExamples <|> blockProp) - <* skipNormalCommentBlock - void takeRest -- just consume the rest - pure (flav, body) - else pure (flav, []) - -skipNormalCommentBlock :: BlockCommentParser Bool -skipNormalCommentBlock = do - BlockEnv {..} <- ask - skipManyTill (normalLineP isLhs $ Block blockRange) $ - False <$ try (optional (chunk "-}") *> eof) - <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) - -testSymbol :: Bool -> CommentStyle -> LineParser () -testSymbol isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> (exampleSymbol <|> propSymbol) - -eob :: LineParser () -eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol - -blockExamples - , blockProp :: - BlockCommentParser TestComment -blockExamples = do - BlockEnv {..} <- ask - (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange - AnExample ran examples <$> resultBlockP -blockProp = do - BlockEnv {..} <- ask - (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange - AProp ran prop <$> resultBlockP - -withRange :: - (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => - ParsecT v s m (t (a, Position)) -> - ParsecT v s m (Range, t a) -withRange p = do - beg <- sourcePosToPosition <$> getSourcePos - as <- p - let fin - | null as = beg - | otherwise = snd $ last $ F.toList as - pure (Range beg fin, fst <$> as) - -resultBlockP :: BlockCommentParser [String] -resultBlockP = do - BlockEnv {..} <- ask - many $ - fmap fst $ nonEmptyNormalLineP isLhs $ - Block blockRange - -positionToSourcePos :: Position -> SourcePos -positionToSourcePos pos = - P.SourcePos - { sourceName = "<block comment>" - , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line - , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character - } - -sourcePosToPosition :: SourcePos -> Position -sourcePosToPosition SourcePos {..} = - Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1) - --- * Line Group Parser - -{- | -Result: a tuple of ordinary line tests and setting sections. - -TODO: Haddock comment can adjacent to vanilla comment: - - @ - -- Vanilla comment - -- Another vanilla - -- | This parses as Haddock comment as GHC - @ - -This behaviour is not yet handled correctly in Eval Plugin; -but for future extension for this, we use a tuple here instead of 'Either'. --} -lineGroupP :: - LineGroupParser - (Maybe (CommentFlavour, [TestComment]), [TestComment]) -lineGroupP = do - (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) - case flav of - Named "setup" -> (Nothing,) <$> lineCommentSectionsP - flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP - --- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] --- Variable not in scope: dummyPosition :: Position - -commentFlavourP :: LineParser CommentFlavour -commentFlavourP = - P.option - Vanilla - ( HaddockNext <$ char '|' - <|> HaddockPrev <$ char '^' - <|> Named <$ char '$' - <* optional hspace - <*> ((:) <$> letterChar <*> P.many alphaNumChar) - ) - <* optional (char ' ') - -lineCommentHeadP :: LineParser () -lineCommentHeadP = do - -- and no operator symbol character follows. - void $ chunk "--" - skipMany $ char '-' - void $ optional $ char ' ' - -lineCommentSectionsP :: - LineGroupParser [TestComment] -lineCommentSectionsP = do - skipMany normalLineCommentP - many $ - exampleLinesGP - <|> uncurry AProp <$> propLineGP <*> resultLinesP - <* skipMany normalLineCommentP - -lexemeLine :: LineGroupParser a -> LineGroupParser a -lexemeLine p = p <* skipMany normalLineCommentP - -resultLinesP :: LineGroupParser [String] -resultLinesP = many nonEmptyLGP - -normalLineCommentP :: LineGroupParser (Range, String) -normalLineCommentP = - parseLine (fst <$ commentFlavourP <*> normalLineP False Line) - -nonEmptyLGP :: LineGroupParser String -nonEmptyLGP = - try $ - fmap snd $ - parseLine $ - fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line - -exampleLinesGP :: LineGroupParser TestComment -exampleLinesGP = - lexemeLine $ - uncurry AnExample . first convexHullRange . NE.unzip - <$> NE.some exampleLineGP - <*> resultLinesP - -convexHullRange :: NonEmpty Range -> Range -convexHullRange nes = - Range (NE.head nes ^. start) (NE.last nes ^. end) - -exampleLineGP :: LineGroupParser (Range, ExampleLine) -exampleLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) - -propLineGP :: LineGroupParser (Range, PropLine) -propLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) - -{- | -Turning a line parser into line group parser consuming a single line comment. -Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. -fails if the input does not start with "--". - -__N.B.__ We don't strip comment flavours. - ->>> pck = (:[]).(:[]) . RawLineComment - ->>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" -Just [">>> A"] - ->>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" -Just [" >>> A"] - ->>> parseMaybe (parseLine takeRest) $ pck "" -Nothing --} -parseLine :: - (Ord (f RawLineComment), Traversable f) => - LineParser a -> - Parsec Void [f RawLineComment] (f a) -parseLine p = - P.token - (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) - mempty - --- * Line Parsers - --- | Non-empty normal line. -nonEmptyNormalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -nonEmptyNormalLineP isLHS style = try $ do - (ln, pos) <- normalLineP isLHS style - guard $ - case style of - Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] - _ -> not $ all C.isSpace ln - pure (ln, pos) - -{- | Normal line is a line neither a example nor prop. - Empty line is normal. --} -normalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -normalLineP isLHS style = do - notFollowedBy - (try $ testSymbol isLHS style) - when (isLHS && is _Block style) $ - void $ count' 0 2 $ char ' ' - consume style - -consume :: CommentStyle -> LineParser (String, Position) -consume style = - case style of - Line -> (,) <$> takeRest <*> getPosition - Block {} -> manyTill_ anySingle (getPosition <* eob) - -getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position -getPosition = sourcePosToPosition <$> getSourcePos - --- | Parses example test line. -exampleLineStrP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (ExampleLine, Position) -exampleLineStrP isLHS style = - try $ - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> exampleSymbol - *> (first ExampleLine <$> consume style) - -exampleSymbol :: LineParser () -exampleSymbol = - chunk ">>>" *> P.notFollowedBy (char '>') - -propSymbol :: LineParser () -propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') - --- | Parses prop test line. -propLineStrP :: - -- | True if Literate HAskell - Bool -> - CommentStyle -> - LineParser (PropLine, Position) -propLineStrP isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> chunk "prop>" - *> P.notFollowedBy (char '>') - *> (first PropLine <$> consume style) - --- * Utilities - -{- | -Given a sequence of tokens increasing in their starting position, -groups them into sublists consisting of contiguous tokens; -Two adjacent tokens are considered to be contiguous if - - * line number increases by 1, and - * they have same starting column. - ->>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] -[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] --} -contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a] -contiguousGroupOn toLineCol = foldr step [] - where - step a [] = [pure a] - step a bss0@((b :| bs) : bss) - | let (aLine, aCol) = toLineCol a - , let (bLine, bCol) = toLineCol b - , aLine + 1 == bLine && aCol == bCol = - (a :| b : bs) : bss - | otherwise = pure a : bss0 - -{- | Given a map from positions, divides them into subgroup - with contiguous line and columns. --} -groupLineComments :: - Map Range a -> [NonEmpty (Range, a)] -groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) - . Map.toList +{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Ide.Plugin.Eval.Parse.Comments where++import qualified Control.Applicative.Combinators.NonEmpty as NE+import Control.Arrow (first, (&&&), (>>>))+import Control.Lens (lensField, lensRules,+ view, (.~), (^.))+import Control.Lens.Extras (is)+import Control.Lens.TH (makeLensesWith,+ makePrisms,+ mappingNamer)+import Control.Monad (guard, void, when)+import Control.Monad.Combinators ()+import Control.Monad.Reader (ask)+import Control.Monad.Trans.Reader (Reader, runReader)+import qualified Data.Char as C+import qualified Data.DList as DL+import qualified Data.Foldable as F+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Functor.Identity+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Void (Void)+import Development.IDE (Position,+ Range (Range))+import Development.IDE.Types.Location (Position (..))+import GHC.Generics hiding (UInt, to)+import Ide.Plugin.Eval.Types+import Language.LSP.Types (UInt)+import Language.LSP.Types.Lens (character, end, line,+ start)+import Text.Megaparsec+import qualified Text.Megaparsec as P+import Text.Megaparsec.Char (alphaNumChar, char,+ eol, hspace,+ letterChar)++{-+We build parsers combining the following three kinds of them:++ * Line parser - paring a single line into an input,+ works both for line- and block-comments.+ A line should be a proper content of lines contained in comment:+ doesn't include starting @--@ and @{\-@ and no ending @-\}@++ * Line comment group parser: parses a contiguous group of+ tuples of position and line comment into sections of line comments.+ Each input MUST start with @--@.++ * Block comment parser: Parsing entire block comment into sections.+ Input must be surrounded by @{\-@ and @-\}@.+-}++-- | Line parser+type LineParser a = forall m. Monad m => ParsecT Void String m a++-- | Line comment group parser+type LineGroupParser = Parsec Void [(Range, RawLineComment)]++data BlockEnv = BlockEnv+ { isLhs :: Bool+ , blockRange :: Range+ }+ deriving (Read, Show, Eq, Ord)++makeLensesWith+ (lensRules & lensField .~ mappingNamer (pure . (++ "L")))+ ''BlockEnv++-- | Block comment parser+type BlockCommentParser = ParsecT Void String (Reader BlockEnv)++-- | Prop line, with "prop>" stripped off+newtype PropLine = PropLine {getPropLine :: String}+ deriving (Show)++-- | Example line, with @>>>@ stripped off+newtype ExampleLine = ExampleLine {getExampleLine :: String}+ deriving (Show)++data TestComment+ = AProp+ { testCommentRange :: Range+ , lineProp :: PropLine+ , propResults :: [String]+ }+ | AnExample+ { testCommentRange :: Range+ , lineExamples :: NonEmpty ExampleLine+ , exampleResults :: [String]+ }+ deriving (Show)++-- | Classification of comments+data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String+ deriving (Read, Show, Eq, Ord)++-- | Single line or block comments?+data CommentStyle = Line | Block Range+ deriving (Read, Show, Eq, Ord, Generic)++makePrisms ''CommentStyle++commentsToSections ::+ -- | True if it is literate Haskell+ Bool ->+ Comments ->+ Sections+commentsToSections isLHS Comments {..} =+ let (lineSectionSeeds, lineSetupSeeds) =+ foldMap+ ( \lcs ->+ let theRan =+ Range+ (view start $ fst $ NE.head lcs)+ (view end $ fst $ NE.last lcs)+ in case parseMaybe lineGroupP $ NE.toList lcs of+ Nothing -> mempty+ Just (mls, rs) ->+ ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls)+ , -- orders setup sections in ascending order+ if null rs+ then mempty+ else+ Map.singleton theRan $+ DL.singleton (Line, rs)+ )+ )+ $ groupLineComments $+ Map.filterWithKey+ -- FIXME:+ -- To comply with the initial behaviour of+ -- Extended Eval Plugin;+ -- but it also rejects modules with+ -- non-zero base indentation level!+ ( \pos _ ->+ if isLHS+ then pos ^. start . character == 2+ else pos ^. start . character == 0+ )+ lineComments+ (blockSeed, blockSetupSeeds) =+ foldMap+ ( \(ran, lcs) ->+ case parseBlockMaybe isLHS ran blockCommentBP $+ getRawBlockComment lcs of+ Nothing -> mempty+ Just (Named "setup", grp) ->+ -- orders setup sections in ascending order+ ( mempty+ , Map.singleton ran $+ DL.singleton (Block ran, grp)+ )+ Just grp ->+ ( Map.singleton ran grp+ , mempty+ )+ )+ -- It seems Extended Eval Plugin doesn't constraint+ -- starting indentation level for block comments.+ -- Rather, it constrains the indentation level /inside/+ -- block comment body.+ $ Map.toList blockComments+ lineSections =+ lineSectionSeeds <&> uncurry (testsToSection Line)+ multilineSections =+ Map.mapWithKey+ (uncurry . testsToSection . Block)+ blockSeed+ setupSections =+ -- Setups doesn't need Dummy position+ map+ ( \(style, tests) ->+ testsToSection+ style+ (Named "setup")+ tests+ )+ $ DL.toList $+ F.fold $+ Map.unionWith (<>) lineSetupSeeds blockSetupSeeds+ nonSetupSections = F.toList $ lineSections `Map.union` multilineSections+ in Sections {..}++parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a+parseBlockMaybe isLhs blockRange p i =+ case runReader (runParserT p' "" i) BlockEnv {..} of+ Left {} -> Nothing+ Right a -> Just a+ where+ p' = do+ updateParserState $ \st ->+ st+ { statePosState =+ (statePosState st)+ { pstateSourcePos = positionToSourcePos $ blockRange ^. start+ }+ }+ p++type CommentRange = Range++type SectionRange = Range++testsToSection ::+ CommentStyle ->+ CommentFlavour ->+ [TestComment] ->+ Section+testsToSection style flav tests =+ let sectionName+ | Named name <- flav = name+ | otherwise = ""+ sectionLanguage = case flav of+ HaddockNext -> Haddock+ HaddockPrev -> Haddock+ _ -> Plain+ sectionTests = map fromTestComment tests+ sectionFormat =+ case style of+ Line -> SingleLine+ Block ran -> MultiLine ran+ in Section {..}++fromTestComment :: TestComment -> Test+fromTestComment AProp {..} =+ Property+ { testline = getPropLine lineProp+ , testOutput = propResults+ , testRange = testCommentRange+ }+fromTestComment AnExample {..} =+ Example+ { testLines = getExampleLine <$> lineExamples+ , testOutput = exampleResults+ , testRange = testCommentRange+ }++-- * Block comment parser++{- $setup+>>> dummyPos = Position 0 0+>>> parseE p = either (error . errorBundlePretty) id . parse p ""+-}++-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}"+-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}])++blockCommentBP ::+ -- | True if Literate Haskell+ BlockCommentParser (CommentFlavour, [TestComment])+blockCommentBP = do+ skipCount 2 anySingle -- "{-"+ void $ optional $ char ' '+ flav <- commentFlavourP+ hit <- skipNormalCommentBlock+ if hit+ then do+ body <-+ many $+ (blockExamples <|> blockProp)+ <* skipNormalCommentBlock+ void takeRest -- just consume the rest+ pure (flav, body)+ else pure (flav, [])++skipNormalCommentBlock :: BlockCommentParser Bool+skipNormalCommentBlock = do+ BlockEnv {..} <- ask+ skipManyTill (normalLineP isLhs $ Block blockRange) $+ False <$ try (optional (chunk "-}") *> eof)+ <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange)++testSymbol :: Bool -> CommentStyle -> LineParser ()+testSymbol isLHS style =+ -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+ -- it must skip one space after a comment!+ -- This prevents Eval Plugin from working on+ -- modules with non-standard base indentation-level.+ when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+ *> (exampleSymbol <|> propSymbol)++eob :: LineParser ()+eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol++blockExamples+ , blockProp ::+ BlockCommentParser TestComment+blockExamples = do+ BlockEnv {..} <- ask+ (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange+ AnExample ran examples <$> resultBlockP+blockProp = do+ BlockEnv {..} <- ask+ (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange+ AProp ran prop <$> resultBlockP++withRange ::+ (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) =>+ ParsecT v s m (t (a, Position)) ->+ ParsecT v s m (Range, t a)+withRange p = do+ beg <- sourcePosToPosition <$> getSourcePos+ as <- p+ let fin+ | null as = beg+ | otherwise = snd $ last $ F.toList as+ pure (Range beg fin, fst <$> as)++resultBlockP :: BlockCommentParser [String]+resultBlockP = do+ BlockEnv {..} <- ask+ many $+ fmap fst $ nonEmptyNormalLineP isLhs $+ Block blockRange++positionToSourcePos :: Position -> SourcePos+positionToSourcePos pos =+ P.SourcePos+ { sourceName = "<block comment>"+ , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line+ , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character+ }++sourcePosToPosition :: SourcePos -> Position+sourcePosToPosition SourcePos {..} =+ Position (fromIntegral $ unPos sourceLine - 1) (fromIntegral $ unPos sourceColumn - 1)++-- * Line Group Parser++{- |+Result: a tuple of ordinary line tests and setting sections.++TODO: Haddock comment can adjacent to vanilla comment:++ @+ -- Vanilla comment+ -- Another vanilla+ -- | This parses as Haddock comment as GHC+ @++This behaviour is not yet handled correctly in Eval Plugin;+but for future extension for this, we use a tuple here instead of 'Either'.+-}+lineGroupP ::+ LineGroupParser+ (Maybe (CommentFlavour, [TestComment]), [TestComment])+lineGroupP = do+ (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest)+ case flav of+ Named "setup" -> (Nothing,) <$> lineCommentSectionsP+ flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP++-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"]+-- Variable not in scope: dummyPosition :: Position++commentFlavourP :: LineParser CommentFlavour+commentFlavourP =+ P.option+ Vanilla+ ( HaddockNext <$ char '|'+ <|> HaddockPrev <$ char '^'+ <|> Named <$ char '$'+ <* optional hspace+ <*> ((:) <$> letterChar <*> P.many alphaNumChar)+ )+ <* optional (char ' ')++lineCommentHeadP :: LineParser ()+lineCommentHeadP = do+ -- and no operator symbol character follows.+ void $ chunk "--"+ skipMany $ char '-'+ void $ optional $ char ' '++lineCommentSectionsP ::+ LineGroupParser [TestComment]+lineCommentSectionsP = do+ skipMany normalLineCommentP+ many $+ exampleLinesGP+ <|> uncurry AProp <$> propLineGP <*> resultLinesP+ <* skipMany normalLineCommentP++lexemeLine :: LineGroupParser a -> LineGroupParser a+lexemeLine p = p <* skipMany normalLineCommentP++resultLinesP :: LineGroupParser [String]+resultLinesP = many nonEmptyLGP++normalLineCommentP :: LineGroupParser (Range, String)+normalLineCommentP =+ parseLine (fst <$ commentFlavourP <*> normalLineP False Line)++nonEmptyLGP :: LineGroupParser String+nonEmptyLGP =+ try $+ fmap snd $+ parseLine $+ fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line++exampleLinesGP :: LineGroupParser TestComment+exampleLinesGP =+ lexemeLine $+ uncurry AnExample . first convexHullRange . NE.unzip+ <$> NE.some exampleLineGP+ <*> resultLinesP++convexHullRange :: NonEmpty Range -> Range+convexHullRange nes =+ Range (NE.head nes ^. start) (NE.last nes ^. end)++exampleLineGP :: LineGroupParser (Range, ExampleLine)+exampleLineGP =+ -- In line-comments, indentation-level inside comment doesn't matter.+ parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line)++propLineGP :: LineGroupParser (Range, PropLine)+propLineGP =+ -- In line-comments, indentation-level inside comment doesn't matter.+ parseLine (fst <$ commentFlavourP <*> propLineStrP False Line)++{- |+Turning a line parser into line group parser consuming a single line comment.+Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space.+fails if the input does not start with "--".++__N.B.__ We don't strip comment flavours.++>>> pck = (:[]).(:[]) . RawLineComment++>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A"+Just [">>> A"]++>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A"+Just [" >>> A"]++>>> parseMaybe (parseLine takeRest) $ pck ""+Nothing+-}+parseLine ::+ (Ord (f RawLineComment), Traversable f) =>+ LineParser a ->+ Parsec Void [f RawLineComment] (f a)+parseLine p =+ P.token+ (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment)+ mempty++-- * Line Parsers++-- | Non-empty normal line.+nonEmptyNormalLineP ::+ -- | True if Literate Haskell+ Bool ->+ CommentStyle ->+ LineParser (String, Position)+nonEmptyNormalLineP isLHS style = try $ do+ (ln, pos) <- normalLineP isLHS style+ guard $+ case style of+ Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""]+ _ -> not $ all C.isSpace ln+ pure (ln, pos)++{- | Normal line is a line neither a example nor prop.+ Empty line is normal.+-}+normalLineP ::+ -- | True if Literate Haskell+ Bool ->+ CommentStyle ->+ LineParser (String, Position)+normalLineP isLHS style = do+ notFollowedBy+ (try $ testSymbol isLHS style)+ when (isLHS && is _Block style) $+ void $ count' 0 2 $ char ' '+ consume style++consume :: CommentStyle -> LineParser (String, Position)+consume style =+ case style of+ Line -> (,) <$> takeRest <*> getPosition+ Block {} -> manyTill_ anySingle (getPosition <* eob)++getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position+getPosition = sourcePosToPosition <$> getSourcePos++-- | Parses example test line.+exampleLineStrP ::+ -- | True if Literate Haskell+ Bool ->+ CommentStyle ->+ LineParser (ExampleLine, Position)+exampleLineStrP isLHS style =+ try $+ -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+ -- it must skip one space after a comment!+ -- This prevents Eval Plugin from working on+ -- modules with non-standard base indentation-level.+ when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+ *> exampleSymbol+ *> (first ExampleLine <$> consume style)++exampleSymbol :: LineParser ()+exampleSymbol =+ chunk ">>>" *> P.notFollowedBy (char '>')++propSymbol :: LineParser ()+propSymbol = chunk "prop>" *> P.notFollowedBy (char '>')++-- | Parses prop test line.+propLineStrP ::+ -- | True if Literate HAskell+ Bool ->+ CommentStyle ->+ LineParser (PropLine, Position)+propLineStrP isLHS style =+ -- FIXME: To comply with existing Extended Eval Plugin Behaviour;+ -- it must skip one space after a comment!+ -- This prevents Eval Plugin from working on+ -- modules with non-standard base indentation-level.+ when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ')+ *> chunk "prop>"+ *> P.notFollowedBy (char '>')+ *> (first PropLine <$> consume style)++-- * Utilities++{- |+Given a sequence of tokens increasing in their starting position,+groups them into sublists consisting of contiguous tokens;+Two adjacent tokens are considered to be contiguous if++ * line number increases by 1, and+ * they have same starting column.++>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)]+[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]]+-}+contiguousGroupOn :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]+contiguousGroupOn toLineCol = foldr step []+ where+ step a [] = [pure a]+ step a bss0@((b :| bs) : bss)+ | let (aLine, aCol) = toLineCol a+ , let (bLine, bCol) = toLineCol b+ , aLine + 1 == bLine && aCol == bCol =+ (a :| b : bs) : bss+ | otherwise = pure a : bss0++{- | Given a map from positions, divides them into subgroup+ with contiguous line and columns.+-}+groupLineComments ::+ Map Range a -> [NonEmpty (Range, a)]+groupLineComments =+ contiguousGroupOn (fst >>> view start >>> view line &&& view character)+ . Map.toList
src/Ide/Plugin/Eval/Rules.hs view
@@ -2,9 +2,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}+ -- To avoid warning "Pattern match has inaccessible right hand side" {-# OPTIONS_GHC -Wno-overlapping-patterns #-}-module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where+module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashSet (HashSet)@@ -32,17 +33,29 @@ addIdeGlobal, getIdeGlobalAction, getIdeGlobalState)+import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun)+import Development.IDE.Types.Logger (Pretty (pretty),+ Recorder, WithPriority,+ cmapWithPrio)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Parser.Annotation+#endif import Ide.Plugin.Eval.Types +newtype Log = LogShake Shake.Log deriving Show -rules :: Rules ()-rules = do- evalParsedModuleRule- redefinedNeedsCompilation+instance Pretty Log where+ pretty = \case+ LogShake shakeLog -> pretty shakeLog++rules :: Recorder (WithPriority Log) -> Rules ()+rules recorder = do+ evalParsedModuleRule recorder+ redefinedNeedsCompilation recorder addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))@@ -53,22 +66,44 @@ EvaluatingVar var <- getIdeGlobalState ide modifyIORef var (Set.insert nfp) -#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]+getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) =+ priorComments annComments <> getFollowingComments annComments+ <> concatMap getCommentsForDecl (hsmodImports m)+ <> concatMap getCommentsForDecl (hsmodDecls m)+ where+ annComments = epAnnComments anns'++getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e+ -> [LEpaComment]+getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs+getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = []++apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]+apiAnnComments' pm = do+ L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm+ pure (L (anchor span) c)+ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]-apiAnnComments' = apiAnnRogueComments+#elif MIN_VERSION_ghc(9,0,0)+apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated AnnotationComment]+apiAnnComments' = apiAnnRogueComments . pm_annotations++pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan+pattern RealSrcSpanAlready x = x #else-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]-apiAnnComments' = concat . Map.elems . snd+apiAnnComments' :: ParsedModule -> [SrcLoc.Located AnnotationComment]+apiAnnComments' = concat . Map.elems . snd . pm_annotations pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif -evalParsedModuleRule :: Rules ()-evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do- (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp+evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()+evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do+ (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap (\case L (RealSrcSpanAlready real) bdy | FastString.unpackFS (srcSpanFile real) ==@@ -80,14 +115,14 @@ -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', -- we can concentrate on these two case bdy of- AnnLineComment cmt ->+ EpaLineComment cmt -> mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }- AnnBlockComment cmt ->+ EpaBlockComment cmt -> mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } _ -> mempty _ -> mempty )- $ apiAnnComments' pm_annotations+ $ apiAnnComments' pm -- we only care about whether the comments are null -- this is valid because the only dependent is NeedsCompilation fingerPrint = fromString $ if nullComments comments then "" else "1"@@ -98,8 +133,8 @@ -- This will ensure that the modules are loaded with linkables -- and the interactive session won't try to compile them on the fly, -- leading to much better performance of the evaluate code lens-redefinedNeedsCompilation :: Rules ()-redefinedNeedsCompilation = defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do+redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()+redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do alwaysRerun EvaluatingVar var <- getIdeGlobalAction
src/Ide/Plugin/Eval/Util.hs view
@@ -4,7 +4,6 @@ -- |Debug utilities module Ide.Plugin.Eval.Util (- asS, timed, isLiterate, response',@@ -20,8 +19,6 @@ import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), ideLogger, logPriority)-import Development.IDE.GHC.Compat (Outputable, ppr,- showSDocUnsafe) import Development.IDE.GHC.Compat.Util (MonadCatch, catch) import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack,@@ -32,9 +29,6 @@ import System.FilePath (takeExtension) import System.Time.Extra (duration, showDuration) import UnliftIO.Exception (catchAny)--asS :: Outputable a => a -> String-asS = showSDocUnsafe . ppr timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b timed out name op = do
test/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-}@@ -9,11 +10,15 @@ import Control.Lens (_Just, folded, preview, toListOf, view, (^..))-import Data.Aeson (fromJSON)-import Data.Aeson.Types (Result (Success))+import Data.Aeson (Value (Object), fromJSON, object,+ toJSON, (.=))+import Data.Aeson.Types (Result (Success), Pair) 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)@@ -25,7 +30,7 @@ main = defaultTestRunner tests evalPlugin :: PluginDescriptor IdeState-evalPlugin = Eval.descriptor "eval"+evalPlugin = Eval.descriptor mempty "eval" tests :: TestTree tests =@@ -65,40 +70,43 @@ , goldenWithEval "Refresh a multiline evaluation" "T7" "hs" , testCase "Semantic and Lexical errors are reported" $ do evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName"- evalInFile "T8.hs" "-- >>> \"a\" + \"bc\"" $- if ghcVersion == GHC90- then "-- No instance for (Num String) arising from a use of ‘+’"- else "-- No instance for (Num [Char]) arising from a use of ‘+’"+ evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $+ if+ | ghcVersion == GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""+ | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’"+ | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’" evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"- evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero"+ evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"- , goldenWithEval "Evaluate a type with :kind!" "T10" "hs"- , goldenWithEval "Reports an error for an incorrect type with :kind!" "T11" "hs"- , goldenWithEval "Shows a kind with :kind" "T12" "hs"- , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs"+ , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")+ , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")+ , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")+ , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs"- , goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"+ , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"- , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs"+ , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" , expectFailBecause "known issue - see a note in P.R. #361" $- goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs"+ goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") , testCase ":type handles a multilined result properly" $ evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ "-- fun",- if ghcVersion == GHC90- then "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."- else "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",+ if+ | ghcVersion == GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."+ | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."+ | otherwise -> "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ] , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs" , testCase ":type does \"dovetails\" for short identifiers" $ evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [- if ghcVersion == GHC90- then "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."- else "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",+ if+ | ghcVersion == GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."+ | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."+ | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ]@@ -115,14 +123,17 @@ , goldenWithEval "Transitive local dependency" "TTransitive" "hs" -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs"- , goldenWithEval ":set accepts ghci flags" "TFlags" "hs"+ , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") , testCase ":set -fprint-explicit-foralls works" $ do evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id"- "-- id :: forall {a}. a -> a"+ (if ghcVersion == GHC92+ then "-- id :: forall a. a -> a"+ else "-- id :: forall {a}. a -> a") , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" , goldenWithEval "Property checking" "TProperty" "hs"+ , goldenWithEval "Property checking with exception" "TPropertyError" "hs" , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"@@ -138,7 +149,12 @@ ] , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs" , goldenWithEval "Variable 'it' works" "TIt" "hs"-+ , testGroup "configuration"+ [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default"+ , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig+ , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False)+ , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True)+ ] , testGroup ":info command" [ testCase ":info reports type, constructors and instances" $ do [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs"@@ -201,6 +217,12 @@ goldenWithEval title path ext = goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards +-- | Similar function as 'goldenWithEval' with an alternate reference file+-- naming. Useful when reference file may change because of GHC version.+goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree+goldenWithEval' title path ext expected =+ goldenWithHaskellDoc evalPlugin title testDataDir path expected ext executeLensesBackwards+ -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () executeLensesBackwards doc = do@@ -242,7 +264,29 @@ testDataDir :: FilePath testDataDir = "test" </> "testdata" -evalInFile :: FilePath -> T.Text -> T.Text -> IO ()+changeConfig :: [Pair] -> Config+changeConfig conf =+ def+ { Plugin.plugins = Map.fromList [("eval",+ def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object conf }+ )] }+ where+ unObject (Object obj) = obj+ unObject _ = undefined++diffOffConfig :: Config+diffOffConfig = changeConfig ["diff" .= False]++exceptionConfig :: Bool -> Config+exceptionConfig exCfg = changeConfig ["exception" .= exCfg]++goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree+goldenWithEvalConfig' title path ext expected cfg =+ goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do+ sendConfigurationChanged (toJSON cfg)+ executeLensesBackwards doc++evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc fp "haskell" origin <- documentContents doc
test/info-util/InfoUtil.hs view
@@ -1,20 +1,20 @@-module InfoUtil - ( Eq - , Ord - , Foo (..) - , Bar (..) - , Baz - ) -where - -import Prelude (Eq, Ord) - -data Foo = Foo1 | Foo2 - deriving (Eq, Ord) - -data Bar = Bar1 | Bar2 | Bar3 - deriving (Eq, Ord) - -class Baz t -instance Baz Foo -instance Baz Bar +module InfoUtil+ ( Eq+ , Ord+ , Foo (..)+ , Bar (..)+ , Baz+ )+where++import Prelude (Eq, Ord)++data Foo = Foo1 | Foo2+ deriving (Eq, Ord)++data Bar = Bar1 | Bar2 | Bar3+ deriving (Eq, Ord)++class Baz t+instance Baz Foo+instance Baz Bar
+ test/testdata/T10.ghc92.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T10 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind! N + M + 1+-- N + M + 1 :: Natural+-- = 42
+ test/testdata/T11.ghc92.expected.hs view
@@ -0,0 +1,4 @@+module T11 where++-- >>> :kind! a+-- Not in scope: type variable `a'
+ test/testdata/T11.ghc92_expected.hs view
@@ -0,0 +1,4 @@+module T11 where++-- >>> :kind! a+-- Not in scope: type variable `a'
+ test/testdata/T12.ghc92.expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1+-- N + M + 1 :: Natural
+ test/testdata/T12.ghc92_expected.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds, TypeOperators #-}+module T12 where+import GHC.TypeNats ( type (+) )++type Dummy = 1 + 1++-- >>> type N = 1+-- >>> type M = 40+-- >>> :kind N + M + 1+-- N + M + 1 :: Natural
+ test/testdata/T13.ghc92.expected.hs view
@@ -0,0 +1,4 @@+module T13 where++-- >>> :kind a+-- Not in scope: type variable `a'
+ test/testdata/T13.ghc92_expected.hs view
@@ -0,0 +1,4 @@+module T13 where++-- >>> :kind a+-- Not in scope: type variable `a'
+ test/testdata/T15.ghc92_expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeApplications #-}+module T15 where++foo :: Show a => a -> String+foo = show++-- >>> :type +v foo @Int+-- foo @Int :: Show Int => Int -> String
+ test/testdata/T17.ghc92.expected.hs view
@@ -0,0 +1,4 @@+module T17 where++-- >>> :type +no 42+-- parse error on input `+'
+ test/testdata/T17.ghc92_expected.hs view
@@ -0,0 +1,4 @@+module T17 where++-- >>> :type +no 42+-- parse error on input ‘+’
+ test/testdata/T20.ghc92.expected.hs view
@@ -0,0 +1,7 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word
+ test/testdata/T20.ghc92_expected.hs view
@@ -0,0 +1,7 @@+module T20 where+import Data.Word (Word)++default (Word)++-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer
+ test/testdata/TDiff.expected.default.hs view
@@ -0,0 +1,8 @@+module TDiff where++-- |+-- >>> myId 5+-- WAS 4+-- NOW 5+myId :: a -> a+myId x = x
+ test/testdata/TDiff.expected.no-diff.hs view
@@ -0,0 +1,7 @@+module TDiff where++-- |+-- >>> myId 5+-- 5+myId :: a -> a+myId x = x
+ test/testdata/TDiff.hs view
@@ -0,0 +1,7 @@+module TDiff where++-- |+-- >>> myId 5+-- 4+myId :: a -> a+myId x = x
+ test/testdata/TException.expected.marked.hs view
@@ -0,0 +1,6 @@+module TException where++-- >>> exceptionalCode+-- *** Exception: I am exceptional!+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ test/testdata/TException.expected.nomark.hs view
@@ -0,0 +1,6 @@+module TException where++-- >>> exceptionalCode+-- I am exceptional!+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ test/testdata/TException.hs view
@@ -0,0 +1,5 @@+module TException where++-- >>> exceptionalCode+exceptionalCode :: Int+exceptionalCode = error "I am exceptional!"
+ test/testdata/TFlags.ghc92.expected.hs view
@@ -0,0 +1,62 @@+-- Support for language options++{-# LANGUAGE ScopedTypeVariables #-}+module TFlags where++-- Language options set in the module source (ScopedTypeVariables)+-- also apply to tests so this works fine+-- >>> f = (\(c::Char) -> [c])++{- Multiple options can be set with a single `:set`++>>> :set -XMultiParamTypeClasses -XFlexibleInstances+>>> class Z a b c+-}++{-++Options apply only in the section where they are defined (unless they are in the setup section), so this will fail:++>>> class L a b c+Too many parameters for class `L'+(Enable MultiParamTypeClasses to allow multi-parameter classes)+In the class declaration for `L'+-}+++{-+Options apply to all tests in the same section after their declaration.++Not set yet:++>>> class D+No parameters for class `D'+(Enable MultiParamTypeClasses to allow no-parameter classes)+In the class declaration for `D'++Now it works:++>>>:set -XMultiParamTypeClasses+>>> class C++It still works++>>> class F+-}++{- Now -package flag is handled correctly:++>>> :set -package ghc-prim+>>> import GHC.Prim++-}+++{- Invalid option/flags are reported, but valid ones will be reflected++>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all+<interactive>: warning:+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.+Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all++-}
+ test/testdata/TPropertyError.expected.hs view
@@ -0,0 +1,6 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l+-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test):+-- []
+ test/testdata/TPropertyError.hs view
@@ -0,0 +1,4 @@+-- Support for property checking+module TProperty where++-- prop> \(l::[Bool]) -> head l