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: 2.2.0.0 +version: 2.3.0.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -20,8 +20,8 @@ LICENSE README.md test/cabal.project - test/info-util/*.cabal - test/info-util/*.hs + test/testdata/info-util/*.cabal + test/testdata/info-util/*.hs test/testdata/*.cabal test/testdata/*.hs test/testdata/*.lhs @@ -67,10 +67,10 @@ , ghc , ghc-boot-th , ghc-paths - , ghcide == 2.2.0.0 + , ghcide == 2.3.0.0 , hashable , hls-graph - , hls-plugin-api == 2.2.0.0 + , hls-plugin-api == 2.3.0.0 , lens , lsp , lsp-types @@ -112,7 +112,7 @@ , filepath , hls-eval-plugin , hls-plugin-api - , hls-test-utils == 2.2.0.0 + , hls-test-utils == 2.3.0.0 , lens , lsp-types , text 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 @@ -25,7 +25,7 @@ import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second, (>>>)) -import Control.Exception (try, bracket_) +import Control.Exception (bracket_, try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) @@ -53,7 +53,8 @@ NeedsCompilation (NeedsCompilation), TypeCheck (..), tmrTypechecked) -import Development.IDE.Core.Shake (useWithStale_, useNoFile_, +import Development.IDE.Core.Shake (useNoFile_, + useWithStale_, use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) @@ -62,7 +63,8 @@ import Development.IDE.GHC.Util (evalGhcEnv, modifyDynFlags, printOutputable) -import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps) +import Development.IDE.Import.DependencyInformation (transitiveDeps, + transitiveModuleDeps) import Development.IDE.Types.Location (toNormalizedFilePath', uriToFilePath') import GHC (ClsInst, @@ -82,9 +84,9 @@ typeKind) -import Development.IDE.Core.RuleTypes (GetModuleGraph (GetModuleGraph), - GetLinkable (GetLinkable), +import Development.IDE.Core.RuleTypes (GetLinkable (GetLinkable), GetModSummary (GetModSummary), + GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) @@ -99,9 +101,7 @@ import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) -#if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) -#endif import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, handleMaybeM) @@ -120,7 +120,8 @@ showDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (parseSetFlags) -import Ide.Plugin.Eval.Rules (queueForEvaluation, unqueueForEvaluation) +import Ide.Plugin.Eval.Rules (queueForEvaluation, + unqueueForEvaluation) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, @@ -491,11 +492,7 @@ void $ runDecls stmt return Nothing pf = initParserOpts df -#if !MIN_VERSION_ghc(9,0,0) - unhelpfulReason = "" -#else unhelpfulReason = UnhelpfulInteractive -#endif exec stmt l = let opts = execOptions{execSourceFile = fp, execLineNumber = l} in myExecStmt stmt opts 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 @@ -102,18 +102,12 @@ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x -#elif MIN_VERSION_ghc(9,0,0) +#else apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated AnnotationComment] apiAnnComments' = apiAnnRogueComments . pm_annotations pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x -#else -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 :: Recorder (WithPriority Log) -> Rules () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -27,8 +27,9 @@ import Language.LSP.Protocol.Lens (arguments, command, range, title) import Language.LSP.Protocol.Message hiding (error) -import System.FilePath (()) +import System.FilePath ((<.>), ()) import Test.Hls +import qualified Test.Hls.FileSystem as FS main :: IO () main = defaultTestRunner tests @@ -40,27 +41,27 @@ tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T3.hs") $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] @@ -122,15 +123,15 @@ ] , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs" , goldenWithEval ":kind treats a multilined result properly" "T25" "hs" - , goldenWithEval "local imports" "T26" "hs" + , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs" , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs" , goldenWithEval "Multi line comments" "TMulti" "hs" , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs" , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs" , goldenWithEval "Evaluate expressions in Haddock comments in both single line and multi line format" "THaddock" "hs" , goldenWithEval "Compare results (for Haddock tests only)" "TCompare" "hs" - , goldenWithEval "Local Modules imports are accessible in a test" "TLocalImport" "hs" - , goldenWithEval "Transitive local dependency" "TTransitive" "hs" + , goldenWithEvalAndFs "Local Modules imports are accessible in a test" (FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) "TLocalImport" "hs" + , goldenWithEvalAndFs "Transitive local dependency" (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "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" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") @@ -142,8 +143,8 @@ 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" ( + , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" + , goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" ( if ghcVersion >= GHC96 then "ghc96.expected" else if ghcVersion >= GHC94 && hostOS == Windows then @@ -212,7 +213,7 @@ not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ] , testCase "Interfaces are reused after Eval" $ do - runSessionWithServer def evalPlugin testDataDir $ do + runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) $ do doc <- openDoc "TLocalImport.hs" "haskell" waitForTypecheck doc lenses <- getCodeLenses doc @@ -231,14 +232,23 @@ goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = - goldenWithHaskellDoc def evalPlugin title testDataDir path "expected" ext executeLensesBackwards + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards +goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs title tree path ext = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) 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 def evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path expected ext executeLensesBackwards +goldenWithEvalAndFs' :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> FilePath -> TestTree +goldenWithEvalAndFs' title tree path ext expected = + goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path expected ext executeLensesBackwards + + -- | Execute lenses backwards, to avoid affecting their position in the source file executeLensesBackwards :: TextDocumentIdentifier -> Session () executeLensesBackwards doc = do @@ -264,7 +274,7 @@ pure () evalLenses :: FilePath -> IO [CodeLens] -evalLenses path = runSessionWithServer def evalPlugin testDataDir $ do +evalLenses path = runSessionWithServerInTmpDir def evalPlugin (mkFs cabalProjectFS) $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc @@ -298,10 +308,11 @@ goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = - goldenWithHaskellDoc cfg evalPlugin title testDataDir path expected ext executeLensesBackwards + goldenWithHaskellDocInTmpDir cfg evalPlugin title (mkFs $ FS.directProject $ path <.> ext) path expected ext $ \doc -> do + executeLensesBackwards doc evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () -evalInFile fp e expected = runSessionWithServer def evalPlugin testDataDir $ do +evalInFile fp e expected = runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject fp) $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e @@ -309,3 +320,30 @@ executeLensesBackwards doc result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc liftIO $ result @?= Just (T.strip expected) + +-- ---------------------------------------------------------------------------- +-- File system definitions +-- Used for declaring a test file tree +-- ---------------------------------------------------------------------------- + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +cabalProjectFS :: [FS.FileTree] +cabalProjectFS = FS.simpleCabalProject' + [ FS.copy "test.cabal" + , FS.file "cabal.project" + (FS.text "packages: ./info-util .\n" + ) + , FS.copy "TProperty.hs" + , FS.copy "TPropertyError.hs" + , FS.copy "TI_Info.hs" + , FS.copy "TInfo.hs" + , FS.copy "TInfoBang.hs" + , FS.copy "TInfoBangMany.hs" + , FS.copy "TInfoMany.hs" + , FS.directory "info-util" + [ FS.copy "info-util/info-util.cabal" + , FS.copy "info-util/InfoUtil.hs" + ] + ] diff --git a/test/info-util/InfoUtil.hs b/test/info-util/InfoUtil.hs deleted file mode 100644 --- a/test/info-util/InfoUtil.hs +++ /dev/null @@ -1,20 +0,0 @@ -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/info-util/info-util.cabal b/test/info-util/info-util.cabal deleted file mode 100644 --- a/test/info-util/info-util.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: info-util -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Author name here -maintainer: example@example.com -copyright: 2017 Author name here -category: Web -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: - InfoUtil - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall -fwarn-unused-imports diff --git a/test/testdata/T11.ghc94.expected.hs b/test/testdata/T11.ghc94.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T11.ghc94.expected.hs @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! A +-- Not in scope: type constructor or class `A' diff --git a/test/testdata/TFlags.expected.hs b/test/testdata/TFlags.expected.hs --- a/test/testdata/TFlags.expected.hs +++ b/test/testdata/TFlags.expected.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/test/testdata/TFlags.ghc92.expected.hs b/test/testdata/TFlags.ghc92.expected.hs --- a/test/testdata/TFlags.ghc92.expected.hs +++ b/test/testdata/TFlags.ghc92.expected.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/test/testdata/TFlags.hs b/test/testdata/TFlags.hs --- a/test/testdata/TFlags.hs +++ b/test/testdata/TFlags.hs @@ -1,6 +1,8 @@ -- Support for language options {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Haskell2010 #-} + module TFlags where -- Language options set in the module source (ScopedTypeVariables) diff --git a/test/testdata/info-util/InfoUtil.hs b/test/testdata/info-util/InfoUtil.hs new file mode 100644 --- /dev/null +++ b/test/testdata/info-util/InfoUtil.hs @@ -0,0 +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 diff --git a/test/testdata/info-util/info-util.cabal b/test/testdata/info-util/info-util.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/info-util/info-util.cabal @@ -0,0 +1,18 @@ +name: info-util +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + InfoUtil + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports diff --git a/test/testdata/test.cabal b/test/testdata/test.cabal --- a/test/testdata/test.cabal +++ b/test/testdata/test.cabal @@ -12,51 +12,8 @@ library exposed-modules: - T1 - T2 - T3 - T4 - T5 - T6 - T7 - T8 - T9 - T10 - T11 - T12 - T13 - T14 - T15 - T16 - T17 - T18 - T19 - T20 - T21 - T22 - T23 - T24 - T25 - T26 - T27 - TEndingMulti - TMulti - TPlainComment - THaddock - TCompare - TLocalImport - TLocalImportInTest - TFlags - TLanguageOptionsTupleSections - TIO TProperty - TSameDefaultLanguageExtensionsAsGhci - TPrelude - TCPP - TLHS - TSetup - Util - TNested + TPropertyError TInfo TInfoMany TInfoBang