diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -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 + } } diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -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/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -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","--"] -} @@ -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) diff --git a/src/Ide/Plugin/Eval/Config.hs b/src/Ide/Plugin/Eval/Config.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Config.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/GHC.hs b/src/Ide/Plugin/Eval/GHC.hs --- a/src/Ide/Plugin/Eval/GHC.hs +++ b/src/Ide/Plugin/Eval/GHC.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/Parse/Comments.hs b/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -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 = "" - , 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 = "" + , 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 diff --git a/src/Ide/Plugin/Eval/Rules.hs b/src/Ide/Plugin/Eval/Rules.hs --- a/src/Ide/Plugin/Eval/Rules.hs +++ b/src/Ide/Plugin/Eval/Rules.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs --- a/src/Ide/Plugin/Eval/Util.hs +++ b/src/Ide/Plugin/Eval/Util.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/info-util/InfoUtil.hs b/test/info-util/InfoUtil.hs --- a/test/info-util/InfoUtil.hs +++ b/test/info-util/InfoUtil.hs @@ -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 diff --git a/test/testdata/T10.ghc92.expected.hs b/test/testdata/T10.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T10.ghc92.expected.hs @@ -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 diff --git a/test/testdata/T11.ghc92.expected.hs b/test/testdata/T11.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T11.ghc92.expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! a +-- Not in scope: type variable `a' diff --git a/test/testdata/T11.ghc92_expected.hs b/test/testdata/T11.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T11.ghc92_expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! a +-- Not in scope: type variable `a' diff --git a/test/testdata/T12.ghc92.expected.hs b/test/testdata/T12.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T12.ghc92.expected.hs @@ -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 diff --git a/test/testdata/T12.ghc92_expected.hs b/test/testdata/T12.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T12.ghc92_expected.hs @@ -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 diff --git a/test/testdata/T13.ghc92.expected.hs b/test/testdata/T13.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T13.ghc92.expected.hs @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind a +-- Not in scope: type variable `a' diff --git a/test/testdata/T13.ghc92_expected.hs b/test/testdata/T13.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T13.ghc92_expected.hs @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind a +-- Not in scope: type variable `a' diff --git a/test/testdata/T15.ghc92_expected.hs b/test/testdata/T15.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T15.ghc92_expected.hs @@ -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 diff --git a/test/testdata/T17.ghc92.expected.hs b/test/testdata/T17.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T17.ghc92.expected.hs @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input `+' diff --git a/test/testdata/T17.ghc92_expected.hs b/test/testdata/T17.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T17.ghc92_expected.hs @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input ‘+’ diff --git a/test/testdata/T20.ghc92.expected.hs b/test/testdata/T20.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T20.ghc92.expected.hs @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/test/testdata/T20.ghc92_expected.hs b/test/testdata/T20.ghc92_expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T20.ghc92_expected.hs @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer diff --git a/test/testdata/TDiff.expected.default.hs b/test/testdata/TDiff.expected.default.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/TDiff.expected.no-diff.hs b/test/testdata/TDiff.expected.no-diff.hs new file mode 100644 --- /dev/null +++ b/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/test/testdata/TDiff.hs b/test/testdata/TDiff.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TDiff.hs @@ -0,0 +1,7 @@ +module TDiff where + +-- | +-- >>> myId 5 +-- 4 +myId :: a -> a +myId x = x diff --git a/test/testdata/TException.expected.marked.hs b/test/testdata/TException.expected.marked.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TException.expected.marked.hs @@ -0,0 +1,6 @@ +module TException where + +-- >>> exceptionalCode +-- *** Exception: I am exceptional! +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/test/testdata/TException.expected.nomark.hs b/test/testdata/TException.expected.nomark.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TException.expected.nomark.hs @@ -0,0 +1,6 @@ +module TException where + +-- >>> exceptionalCode +-- I am exceptional! +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/test/testdata/TException.hs b/test/testdata/TException.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TException.hs @@ -0,0 +1,5 @@ +module TException where + +-- >>> exceptionalCode +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/test/testdata/TFlags.ghc92.expected.hs b/test/testdata/TFlags.ghc92.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFlags.ghc92.expected.hs @@ -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 +: 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 + +-} diff --git a/test/testdata/TPropertyError.expected.hs b/test/testdata/TPropertyError.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPropertyError.expected.hs @@ -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): +-- [] diff --git a/test/testdata/TPropertyError.hs b/test/testdata/TPropertyError.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPropertyError.hs @@ -0,0 +1,4 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l