diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,26 @@ # Changelog for haskell-language-server -## 2.3.0.0.0 +## 2.4.0.0 + +* Initial support for GHC 9.8.1, without plugins dependent on `ghc-exactprint` +* Fix broken Windows binaries (#3822) + +### Pull Requests + +- Remove constraint on stm-hamt + ([#3829](https://github.com/haskell/haskell-language-server/pull/3829)) by @iMichka +- Cleanup func-test suite + ([#3828](https://github.com/haskell/haskell-language-server/pull/3828)) by @fendor +- Bump haskell/actions from 2.4.6 to 2.4.7 in /.github/actions/setup-build + ([#3824](https://github.com/haskell/haskell-language-server/pull/3824)) by @dependabot[bot] +- Bump haskell/actions from 2.4.6 to 2.4.7 + ([#3823](https://github.com/haskell/haskell-language-server/pull/3823)) by @dependabot[bot] +- Release 2.3.0.0 + ([#3818](https://github.com/haskell/haskell-language-server/pull/3818)) by @wz1000 +- GHC 9.8 support + ([#3727](https://github.com/haskell/haskell-language-server/pull/3727)) by @wz1000 + +## 2.3.0.0 * Binaries for GHC 9.6.3 * Drop support for GHC 8.10 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 category: Development name: haskell-language-server -version: 2.3.0.0 +version: 2.4.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at @@ -198,129 +198,129 @@ common cabalfmt if flag(cabalfmt) - build-depends: hls-cabal-fmt-plugin == 2.3.0.0 + build-depends: hls-cabal-fmt-plugin == 2.4.0.0 cpp-options: -Dhls_cabalfmt common cabal if flag(cabal) - build-depends: hls-cabal-plugin == 2.3.0.0 + build-depends: hls-cabal-plugin == 2.4.0.0 cpp-options: -Dhls_cabal common class - if flag(class) - build-depends: hls-class-plugin == 2.3.0.0 + if flag(class) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-class-plugin == 2.4.0.0 cpp-options: -Dhls_class common callHierarchy if flag(callHierarchy) - build-depends: hls-call-hierarchy-plugin == 2.3.0.0 + build-depends: hls-call-hierarchy-plugin == 2.4.0.0 cpp-options: -Dhls_callHierarchy common eval if flag(eval) - build-depends: hls-eval-plugin == 2.3.0.0 + build-depends: hls-eval-plugin == 2.4.0.0 cpp-options: -Dhls_eval common importLens if flag(importLens) - build-depends: hls-explicit-imports-plugin == 2.3.0.0 + build-depends: hls-explicit-imports-plugin == 2.4.0.0 cpp-options: -Dhls_importLens common rename - if flag(rename) - build-depends: hls-rename-plugin == 2.3.0.0 + if flag(rename) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-rename-plugin == 2.4.0.0 cpp-options: -Dhls_rename common retrie - if flag(retrie) - build-depends: hls-retrie-plugin == 2.3.0.0 + if flag(retrie) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-retrie-plugin == 2.4.0.0 cpp-options: -Dhls_retrie common hlint - if flag(hlint) - build-depends: hls-hlint-plugin == 2.3.0.0 + if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-hlint-plugin == 2.4.0.0 cpp-options: -Dhls_hlint common moduleName if flag(moduleName) - build-depends: hls-module-name-plugin == 2.3.0.0 + build-depends: hls-module-name-plugin == 2.4.0.0 cpp-options: -Dhls_moduleName common pragmas if flag(pragmas) - build-depends: hls-pragmas-plugin == 2.3.0.0 + build-depends: hls-pragmas-plugin == 2.4.0.0 cpp-options: -Dhls_pragmas common splice - if flag(splice) - build-depends: hls-splice-plugin == 2.3.0.0 + if flag(splice) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-splice-plugin == 2.4.0.0 cpp-options: -Dhls_splice common alternateNumberFormat if flag(alternateNumberFormat) - build-depends: hls-alternate-number-format-plugin == 2.3.0.0 + build-depends: hls-alternate-number-format-plugin == 2.4.0.0 cpp-options: -Dhls_alternateNumberFormat common qualifyImportedNames if flag(qualifyImportedNames) - build-depends: hls-qualify-imported-names-plugin == 2.3.0.0 + build-depends: hls-qualify-imported-names-plugin == 2.4.0.0 cpp-options: -Dhls_qualifyImportedNames common codeRange if flag(codeRange) - build-depends: hls-code-range-plugin == 2.3.0.0 + build-depends: hls-code-range-plugin == 2.4.0.0 cpp-options: -Dhls_codeRange common changeTypeSignature if flag(changeTypeSignature) - build-depends: hls-change-type-signature-plugin == 2.3.0.0 + build-depends: hls-change-type-signature-plugin == 2.4.0.0 cpp-options: -Dhls_changeTypeSignature common gadt - if flag(gadt) - build-depends: hls-gadt-plugin == 2.3.0.0 + if flag(gadt) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-gadt-plugin == 2.4.0.0 cpp-options: -Dhls_gadt common explicitFixity if flag(explicitFixity) - build-depends: hls-explicit-fixity-plugin == 2.3.0.0 + build-depends: hls-explicit-fixity-plugin == 2.4.0.0 cpp-options: -DexplicitFixity common explicitFields if flag(explicitFields) - build-depends: hls-explicit-record-fields-plugin == 2.3.0.0 + build-depends: hls-explicit-record-fields-plugin == 2.4.0.0 cpp-options: -DexplicitFields common overloadedRecordDot if flag(overloadedRecordDot) && (impl(ghc >= 9.2.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-overloaded-record-dot-plugin == 2.3.0.0 + build-depends: hls-overloaded-record-dot-plugin == 2.4.0.0 cpp-options: -Dhls_overloaded_record_dot -- formatters common floskell if flag(floskell) && impl(ghc < 9.5) - build-depends: hls-floskell-plugin == 2.3.0.0 + build-depends: hls-floskell-plugin == 2.4.0.0 cpp-options: -Dhls_floskell common fourmolu - if flag(fourmolu) - build-depends: hls-fourmolu-plugin == 2.3.0.0 + if flag(fourmolu) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-fourmolu-plugin == 2.4.0.0 cpp-options: -Dhls_fourmolu common ormolu if flag(ormolu) && impl(ghc < 9.7) - build-depends: hls-ormolu-plugin == 2.3.0.0 + build-depends: hls-ormolu-plugin == 2.4.0.0 cpp-options: -Dhls_ormolu common stylishHaskell - if flag(stylishHaskell) - build-depends: hls-stylish-haskell-plugin == 2.3.0.0 + if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-stylish-haskell-plugin == 2.4.0.0 cpp-options: -Dhls_stylishHaskell common refactor - if flag(refactor) - build-depends: hls-refactor-plugin == 2.3.0.0 + if flag(refactor) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + build-depends: hls-refactor-plugin == 2.4.0.0 cpp-options: -Dhls_refactor library @@ -372,12 +372,12 @@ , cryptohash-sha1 , data-default , ghc - , ghcide == 2.3.0.0 + , ghcide == 2.4.0.0 , githash >=0.1.6.1 , lsp >= 2.2.0.0 , hie-bios , hiedb - , hls-plugin-api == 2.3.0.0 + , hls-plugin-api == 2.4.0.0 , optparse-applicative , optparse-simple , process @@ -516,7 +516,7 @@ , lens-aeson , ghcide , ghcide-test-utils - , hls-test-utils == 2.3.0.0 + , hls-test-utils == 2.4.0.0 , lsp-types , aeson , hls-plugin-api @@ -529,21 +529,11 @@ main-is: Main.hs other-modules: - Command - Completion Config - Deferred - Definition - Diagnostic Format FunctionalBadProject - FunctionalCodeAction HieBios - Highlight Progress - Reference - Symbol - TypeDefinition Test.Hls.Command Test.Hls.Flags diff --git a/test/functional/Command.hs b/test/functional/Command.hs deleted file mode 100644 --- a/test/functional/Command.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Command (tests) where - -import Control.Lens hiding (List) -import Data.Char -import qualified Data.Text as T -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Types as LSP -import Test.Hls -import Test.Hls.Command -import Test.Hls.Flags (requiresEvalPlugin) - -tests :: TestTree -tests = testGroup "commands" [ - testCase "are prefixed" $ - runSession hlsCommand fullCaps "test/testdata/" $ do - TResponseMessage _ _ (Right res) <- initializeResponse - let cmds = res ^. L.capabilities . L.executeCommandProvider . _Just . L.commands - f x = (T.length (T.takeWhile isNumber x) >= 1) && (T.count ":" x >= 2) - liftIO $ do - all f cmds @? "All prefixed" - not (null cmds) @? "Commands aren't empty" - , requiresEvalPlugin $ testCase "get de-prefixed" $ - runSession hlsCommand fullCaps "test/testdata/" $ do - TResponseMessage _ _ (Left err) <- request - SMethod_WorkspaceExecuteCommand - (ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just [])) - let ResponseError _ msg _ = err - -- We expect an error message about the dud arguments, but we can - -- check that we found the right plugin. - liftIO $ "while parsing args for evalCommand in plugin eval" `T.isInfixOf` msg @? "Has error message" - ] diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs deleted file mode 100644 --- a/test/functional/Completion.hs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Completion(tests) where - -import Control.Lens hiding ((.=)) -import Data.Aeson (toJSON) -import Data.Foldable (find) -import Data.Functor (void) -import qualified Data.Map as Map -import Data.Row.Records (focus) -import qualified Data.Text as T -import Ide.Plugin.Config (maxCompletions, plcConfig, plugins) -import Language.LSP.Protocol.Lens hiding (applyEdit, length) -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "completions" [ - testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 9) - item <- getCompletionByLabel "putStrLn" compls - liftIO $ do - item ^. label @?= "putStrLn" - item ^. kind @?= Just CompletionItemKind_Function - item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "putStrLn" - - , testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 9) - item <- getCompletionByLabel "putStrLn" compls - liftIO $ do - item ^. label @?= "putStrLn" - item ^. kind @?= Just CompletionItemKind_Function - item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "putStrLn" - - , testCase "completes imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - waitForKickDone - - let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 1 23) - item <- getCompletionByLabel "Maybe" compls - liftIO $ do - item ^. label @?= "Maybe" - item ^. detail @?= Just "Data.Maybe" - item ^. kind @?= Just CompletionItemKind_Module - - , testCase "completes qualified imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - _ <- waitForKickDone - - let te = TextEdit (Range (Position 2 17) (Position 2 25)) "Data.L" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 2 24) - item <- getCompletionByLabel "List" compls - liftIO $ do - item ^. label @?= "List" - item ^. detail @?= Just "Data.List" - item ^. kind @?= Just CompletionItemKind_Module - - , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 5 7) - liftIO $ assertBool "Expected completions" $ not $ null compls - - , expectFailIfBeforeGhc92 "record dot syntax is introduced in GHC 9.2" - $ testGroup "recorddotsyntax" - [ testCase "shows field selectors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "RecordDotSyntax.hs" "haskell" - - let te = TextEdit (Range (Position 25 0) (Position 25 5)) "z = x.a" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 25 6) - item <- getCompletionByLabel "a" compls - - liftIO $ do - item ^. label @?= "a" - , testCase "shows field selectors for nested field" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "RecordDotSyntax.hs" "haskell" - - let te = TextEdit (Range (Position 27 0) (Position 27 8)) "z2 = x.c.z" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 27 9) - item <- getCompletionByLabel "z" compls - - liftIO $ do - item ^. label @?= "z" - ] - - -- See https://github.com/haskell/haskell-ide-engine/issues/903 - , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "DupRecFields.hs" "haskell" - - let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 4) - item <- getCompletionByLabel "accessor" compls - liftIO $ do - item ^. label @?= "accessor" - item ^. kind @?= Just CompletionItemKind_Function - , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" - _ <- applyEdit doc te - compls <- getAndResolveCompletions doc (Position 5 9) - item <- getCompletionByLabel "id" compls - liftIO $ do - item ^. detail @?= Just ":: a -> a\nfrom Prelude" - - , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" - _ <- applyEdit doc te - compls <- getAndResolveCompletions doc (Position 5 11) - item <- getCompletionByLabel "flip" compls - liftIO $ - item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c\nfrom Prelude" - - , testCase "maxCompletions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 5 7) - liftIO $ length compls @?= maxCompletions def - - , testCase "import function completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "FunctionCompletions.hs" "haskell" - - let te = TextEdit (Range (Position 0 30) (Position 0 41)) "A" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 0 31) - item <- getCompletionByLabel "Alternative" compls - liftIO $ do - item ^. label @?= "Alternative" - item ^. kind @?= Just CompletionItemKind_Function - item ^. detail @?= Just "Control.Applicative" - - , testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "FunctionCompletions.hs" "haskell" - - let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 0 42) - item <- getCompletionByLabel "liftA" compls - liftIO $ do - item ^. label @?= "liftA" - item ^. kind @?= Just CompletionItemKind_Function - item ^. detail @?= Just "Control.Applicative" - - , testCase "completes locally defined associated type family" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "AssociatedTypeFamily.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 5 20) - item <- getCompletionByLabel "Fam" compls - liftIO $ do - item ^. label @?= "Fam" - item ^. kind @?= Just CompletionItemKind_Struct - - , contextTests - , snippetTests - ] - -snippetTests :: TestTree -snippetTests = testGroup "snippets" [ - testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 14) - item <- getCompletionByLabel "Nothing" compls - liftIO $ do - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "Nothing" - - , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 11) - item <- getCompletionByLabel "foldl" compls - liftIO $ do - item ^. label @?= "foldl" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "foldl" - - , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 11) - item <- getCompletionByLabel "mapM" compls - liftIO $ do - item ^. label @?= "mapM" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "mapM" - - , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 18) - item <- getCompletionByLabel "filter" compls - liftIO $ do - item ^. label @?= "filter" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_PlainText - item ^. insertText @?= Nothing - - , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 18) - item <- getCompletionByLabel "filter" compls - liftIO $ do - item ^. label @?= "filter" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_PlainText - item ^. insertText @?= Nothing - - , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 29) - item <- getCompletionByLabel "intersperse" compls - liftIO $ do - item ^. label @?= "intersperse" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_PlainText - item ^. insertText @?= Nothing - - , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 29) - item <- getCompletionByLabel "intersperse" compls - liftIO $ do - item ^. label @?= "intersperse" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_PlainText - item ^. insertText @?= Nothing - - , testCase "respects lsp configuration" $ runSessionWithConfig (def {ignoreConfigurationRequests=False}) hlsCommand fullCaps "test/testdata/completion" $ do - void configurationRequest - doc <- openDoc "Completion.hs" "haskell" - - let config = def { plugins = Map.insert "ghcide-completions" (def { plcConfig = [("snippetsOn", (toJSON False))]}) (plugins def) } - - setHlsConfig config - - checkNoSnippets doc - - , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do - doc <- openDoc "Completion.hs" "haskell" - - checkNoSnippets doc - , testCase "works for record fields sharing the single signature" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "FieldsSharingSignature.hs" "haskell" - - let te = TextEdit (Range (Position 1 0) (Position 1 2)) "MkF" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 1 6) - item <- case find (\c -> (c ^. label == "MkFoo") && maybe False ("MkFoo {" `T.isPrefixOf`) (c ^. insertText)) compls of - Just c -> pure c - Nothing -> liftIO . assertFailure $ "Completion with label 'MkFoo' and insertText starting with 'MkFoo {' not found among " <> show compls - liftIO $ do - item ^. insertTextFormat @?= Just InsertTextFormat_Snippet - item ^. insertText @?= Just "MkFoo {arg1=${1:_arg1}, arg2=${2:_arg2}, arg3=${3:_arg3}, arg4=${4:_arg4}, arg5=${5:_arg5}}" - ] - where - checkNoSnippets doc = do - let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" - _ <- applyEdit doc te - - compls <- getAndResolveCompletions doc (Position 5 11) - item <- getCompletionByLabel "foldl" compls - liftIO $ do - item ^. label @?= "foldl" - item ^. kind @?= Just CompletionItemKind_Function - item ^. insertTextFormat @?= Just InsertTextFormat_PlainText - item ^. insertText @?= Nothing - - noSnippetsCaps = - ( textDocument - . _Just - . completion - . _Just - . completionItem - . _Just - . focus #snippetSupport - ?~ False - ) - fullCaps - -contextTests :: TestTree -contextTests = testGroup "contexts" [ - testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Context.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 2 17) - liftIO $ do - compls `shouldContainCompl` "Integer" - compls `shouldNotContainCompl` "interact" - - , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Context.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 3 10) - liftIO $ do - compls `shouldContainCompl` "abs" - compls `shouldNotContainCompl` "Applicative" - - , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - doc <- openDoc "Context.hs" "haskell" - - compls <- getAndResolveCompletions doc (Position 2 26) - liftIO $ do - compls `shouldNotContainCompl` "forkOn" - compls `shouldContainCompl` "MVar" - compls `shouldContainCompl` "Chan" - ] - -shouldContainCompl :: [CompletionItem] -> T.Text -> Assertion -compls `shouldContainCompl` lbl = - any ((== lbl) . (^. label)) compls - @? "Should contain completion: " ++ show lbl - -shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion -compls `shouldNotContainCompl` lbl = - all ((/= lbl) . (^. label)) compls - @? "Should not contain completion: " ++ show lbl - -expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree -expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC90] diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs deleted file mode 100644 --- a/test/functional/Deferred.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -module Deferred(tests) where - -import Control.Lens hiding (List) --- import Control.Monad --- import Data.Maybe -import Language.LSP.Protocol.Lens hiding (id, length, message) -import Language.LSP.Protocol.Types (Null (Null)) --- import qualified Language.LSP.Types.Lens as LSP -import Test.Hls -import Test.Hls.Command - - -tests :: TestTree -tests = testGroup "deferred responses" [ - - --TODO: DOes not compile - -- testCase "do not affect hover requests" $ runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "FuncTest.hs" "haskell" - - -- id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) - - -- skipMany anyNotification - -- hoverRsp <- message :: Session HoverResponse - -- liftIO $ hoverRsp ^? result . _Just . _Just . contents @?= Nothing - -- liftIO $ hoverRsp ^. LSP.id @?= responseId id1 - - -- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) - -- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse - -- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2 - - -- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) - -- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse - -- liftIO $ hoverRsp2 ^. LSP.id @?= responseId id3 - - -- let contents2 = hoverRsp2 ^? result . _Just . _Just . contents - -- liftIO $ contents2 `shouldNotSatisfy` null - - -- -- Now that we have cache the following request should be instant - -- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing - -- highlightRsp <- request TextDocumentDocumentHighlight highlightParams - -- let (Just (List locations)) = highlightRsp ^. result - -- liftIO $ locations @?= [ DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 7, _character = 0} - -- , _end = Position {_line = 7, _character = 2} - -- } - -- , _kind = Just HkWrite - -- } - -- , DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 7, _character = 0} - -- , _end = Position {_line = 7, _character = 2} - -- } - -- , _kind = Just HkWrite - -- } - -- , DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 5, _character = 6} - -- , _end = Position {_line = 5, _character = 8} - -- } - -- , _kind = Just HkRead - -- } - -- , DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 7, _character = 0} - -- , _end = Position {_line = 7, _character = 2} - -- } - -- , _kind = Just HkWrite - -- } - -- , DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 7, _character = 0} - -- , _end = Position {_line = 7, _character = 2} - -- } - -- , _kind = Just HkWrite - -- } - -- , DocumentHighlight - -- { _range = Range - -- { _start = Position {_line = 5, _character = 6} - -- , _end = Position {_line = 5, _character = 8} - -- } - -- , _kind = Just HkRead - -- } - -- ] - - testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "FuncTestFail.hs" "haskell" - defs <- getDefinitions doc (Position 1 11) - liftIO $ defs @?= InR (InR Null) - - -- TODO: the benefits of caching parsed modules is doubted. - -- TODO: add issue link - -- , testCase "respond to untypecheckable modules with parsed module cache" $ - -- runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "FuncTestFail.hs" "haskell" - -- (Left (sym:_)) <- getDocumentSymbols doc - -- liftIO $ sym ^. name @?= "main" - - -- TODO does not compile - -- , testCase "returns hints as diagnostics" $ runSession hlsCommand fullCaps "test/testdata" $ do - -- _ <- openDoc "FuncTest.hs" "haskell" - - -- cwd <- liftIO getCurrentDirectory - -- let testUri = filePathToUri $ cwd "test/testdata/FuncTest.hs" - - -- diags <- publishDiagnosticsNotification - -- liftIO $ diags ^? params @?= (Just $ PublishDiagnosticsParams - -- { _uri = testUri - -- , _diagnostics = List - -- [ Diagnostic - -- (Range (Position 9 6) (Position 10 18)) - -- (Just DsInfo) - -- (Just (StringValue "Redundant do")) - -- (Just "hlint") - -- "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" - -- Nothing - -- ] - -- } - -- ) - -- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)] - -- args = List [Object args'] - -- - -- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing) - -- liftIO $ executeRsp ^. result @?= Just (Object H.empty) - - -- editReq <- message :: Session ApplyWorkspaceEditRequest - -- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"] - -- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] - -- liftIO $ editReq ^. params . edit @?= WorkspaceEdit - -- Nothing - -- (Just expectedTextDocEdits) - -- , multiServerTests - , multiMainTests - ] - ---TODO: Does not compile --- multiServerTests :: TestTree --- multiServerTests = testGroup "multi-server setup" [ --- testCase "doesn't have clashing commands on two servers" $ do --- let getCommands = runSession hlsCommand fullCaps "test/testdata" $ do --- rsp <- initializeResponse --- let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands --- return $ fromJust uuids --- List uuids1 <- getCommands --- List uuids2 <- getCommands --- liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe) --- ] - -multiMainTests :: TestTree -multiMainTests = testGroup "multiple main modules" [ - ignoreTestBecause "Broken: Unexpected ConduitParser.empty" $ - testCase "Can load one file at a time, when more than one Main module exists" - $ runSession hlsCommand fullCaps "test/testdata" $ do - _doc <- openDoc "ApplyRefact2.hs" "haskell" - _diagsRspHlint <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) - diagsRspGhc <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) - let diags = diagsRspGhc ^. params . diagnostics - - liftIO $ length diags @?= 2 - - _doc2 <- openDoc "HaReRename.hs" "haskell" - _diagsRspHlint2 <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) - -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification - diagsRsp2 <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) - let diags2 = diagsRsp2 ^. params . diagnostics - - liftIO $ show diags2 @?= "[]" - ] diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs deleted file mode 100644 --- a/test/functional/Definition.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Definition (tests) where - -import Control.Lens -import Language.LSP.Protocol.Lens -import System.Directory -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "definitions" [symbolTests, moduleTests] - -symbolTests :: TestTree -symbolTests = testGroup "gotoDefinition on symbols" - -- gotoDefinition where the definition is in the same file - [ testCase "gotoDefinition in this file" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "References.hs" "haskell" - defs <- getDefinitions doc (Position 7 8) - let expRange = Range (Position 4 0) (Position 4 3) - liftIO $ defs @?= InL (Definition (InR [Location (doc ^. uri) expRange])) - - -- gotoDefinition where the definition is in a different file - , testCase "gotoDefinition in other file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - defs <- getDefinitions doc (Position 4 11) - let expRange = Range (Position 2 0) (Position 2 1) - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) - - -- gotoDefinition where the definition is in a different file and the - -- definition in the other file is on a line number that is greater - -- than the number of lines in the file we are requesting from - , testCase "gotoDefinition in other file past lines in this file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - defs <- getDefinitions doc (Position 5 13) - let expRange = Range (Position 8 0) (Position 8 1) - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) - ] - - -- ----------------------------------- - -moduleTests :: TestTree -moduleTests = testGroup "gotoDefinition on modules" - [ ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ - testCase "goto's imported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - defs <- getDefinitions doc (Position 2 8) - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) - - , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ - testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - defs <- getDefinitions doc (Position 0 15) - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) - - , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ - testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - _ <- openDoc "Bar.hs" "haskell" - defs <- getDefinitions doc (Position 2 8) - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) - - , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ - testCase "goto's imported modules that are loaded, and then closed" $ - runSession hlsCommand fullCaps "test/testdata/definition" $ do - doc <- openDoc "Foo.hs" "haskell" - otherDoc <- openDoc "Bar.hs" "haskell" - closeDoc otherDoc - defs <- getDefinitions doc (Position 2 8) - _ <- waitForDiagnostics - liftIO $ putStrLn "D" - liftIO $ do - fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) - liftIO $ putStrLn "E" -- AZ - - noDiagnostics - ] - -zeroRange :: Range -zeroRange = Range (Position 0 0) (Position 0 0) diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs deleted file mode 100644 --- a/test/functional/Diagnostic.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Diagnostic (tests) where - -import Control.Lens hiding (List) -import qualified Language.LSP.Protocol.Lens as L -import Test.Hls -import Test.Hls.Command - --- --------------------------------------------------------------------- - -tests :: TestTree -tests = testGroup "diagnostics providers" [ warningTests ] - - -warningTests :: TestTree -warningTests = testGroup "Warnings are warnings" [ - testCase "Overrides -Werror" $ - runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do - doc <- openDoc "src/WError.hs" "haskell" - [diag] <- waitForDiagnosticsFrom doc - liftIO $ diag ^. L.severity @?= Just DiagnosticSeverity_Warning - ] - diff --git a/test/functional/Format.hs b/test/functional/Format.hs --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -4,10 +4,8 @@ import Control.Lens ((^.)) import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy as BS import Data.Functor (void) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -19,34 +17,13 @@ requiresOrmoluPlugin) tests :: TestTree -tests = testGroup "format document" [ - requiresOrmoluPlugin $ goldenGitDiff "works" "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , requiresOrmoluPlugin $ goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - doc <- openDoc "Format.hs" "haskell" - formatDoc doc (FormattingOptions 5 True Nothing Nothing Nothing) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , rangeTests - , providerTests - ] - -rangeTests :: TestTree -rangeTests = requiresOrmoluPlugin $ testGroup "format range" [ - goldenGitDiff "works" "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 5 0) (Position 7 10)) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_range_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do - doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 5 True Nothing Nothing Nothing) (Range (Position 8 0) (Position 11 19)) - BS.fromStrict . T.encodeUtf8 <$> documentContents doc +tests = testGroup "format document" + [ providerTests ] providerTests :: TestTree -providerTests = testGroup "formatting provider" [ - testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do +providerTests = testGroup "lsp formatting provider" + [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do void configurationRequest doc <- openDoc "Format.hs" "haskell" resp <- request SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -16,7 +16,7 @@ doc <- openDoc "src/MyLib.hs" "haskell" [diag] <- waitForDiagnosticsFrom doc liftIO $ assertBool "missing module name" $ "MyLib" `T.isInfixOf` (diag ^. L.message) - liftIO $ assertBool "module missing context" $ "may not be listed" `T.isInfixOf` (diag ^. L.message) + liftIO $ assertBool "module missing context" $ "may not be listed" `T.isInfixOf` (diag ^. L.message) , testCase "Missing module diagnostic - no matching prefix" $ do runSession hlsCommand fullCaps "test/testdata/missingModuleTest/noPrefixMatch/" $ do doc <- openDoc "app/Other.hs" "haskell" diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs deleted file mode 100644 --- a/test/functional/FunctionalCodeAction.hs +++ /dev/null @@ -1,416 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} - -module FunctionalCodeAction (tests) where - -import Control.Lens hiding (List) -import Control.Monad -import Data.Aeson.Lens (_Object) -import Data.List -import Data.Maybe -import qualified Data.Text as T -import Development.IDE.Core.Compile (sourceTypecheck) -import Development.IDE.Test (configureCheckProject) -import Ide.Plugin.Config -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Test as Test -import Test.Hls -import Test.Hls.Command -import Test.Hspec.Expectations - -{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} - -tests :: TestTree -tests = testGroup "code actions" [ -#if hls_refactor - importTests - , ignoreInEnv [HostOS Windows, GhcVer GHC94] "Diagnostic failure for Windows-ghc9.4.2" importQualifiedTests - , ignoreInEnv [HostOS Windows, GhcVer GHC94] "Diagnostic failure for Windows-ghc9.4.2" importQualifiedPostTests - , packageTests - , redundantImportTests - , renameTests - , signatureTests - , typedHoleTests - , unusedTermTests -#endif - ] - -renameTests :: TestTree -renameTests = testGroup "rename suggestions" [ - testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do - doc <- openDoc "CodeActionRename.hs" "haskell" - - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - - cars <- getAllCodeActions doc - replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] - executeCommand replaceButStrLn - _ <- anyRequest - - x:_ <- T.lines <$> documentContents doc - liftIO $ x @?= "main = putStrLn \"hello\"" - - , testCase "doesn't give both documentChanges and changes" - $ runSession hlsCommand noLiteralCaps "test/testdata" $ do - configureCheckProject False - doc <- openDoc "CodeActionRename.hs" "haskell" - - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - - cars <- getAllCodeActions doc - cmd <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] - let mbArgs = cmd ^. L.arguments - case mbArgs of - Just [args] -> liftIO $ do - let editParams = args ^. ix "fallbackWorkspaceEdit" . _Object - (editParams & has (ix "changes")) @? "Contains changes" - not (editParams & has (ix "documentChanges")) @? "Doesn't contain documentChanges" - _ -> error $ "Unexpected arguments: " ++ show mbArgs - - executeCommand cmd - _ <- anyRequest - - x1:x2:_ <- T.lines <$> documentContents doc - liftIO $ - x1 == "main = putStrLn \"hello\"" - || x2 == "foo = putStrLn \"world\"" - @? "One of the typos got fixed" - ] - -importTests :: TestTree -importTests = testGroup "import suggestions" [ - testCase "import works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "CodeActionImport.hs" "haskell" - - (diag:_) <- waitForDiagnosticsFrom doc - liftIO $ diag ^. L.message @?= "Variable not in scope: when :: Bool -> IO () -> IO ()" - - actionsOrCommands <- getAllCodeActions doc - let actns = map fromAction actionsOrCommands - - importControlMonad <- liftIO $ inspectCodeAction actionsOrCommands ["import Control.Monad"] - liftIO $ do - expectCodeAction actionsOrCommands ["import Control.Monad (when)"] - length actns >= 10 @? "There are some actions" - - executeCodeAction importControlMonad - - contents <- documentContents doc - liftIO $ contents @?= "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" - ] - -importQualifiedTests :: TestTree -importQualifiedTests = testGroup "import qualified prefix suggestions" [ - testCase "qualified import works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "CodeActionImportQualified.hs" "haskell" - (diag:_) <- waitForDiagnosticsFrom doc - liftIO $ diag ^. L.message @?= - if ghcVersion >= GHC96 - then "Variable not in scope: Control.when :: Bool -> IO () -> IO ()\nNB: no module named ‘Control’ is imported." - else "Not in scope: ‘Control.when’\nNo module named ‘Control’ is imported." - - actionsOrCommands <- getAllCodeActions doc - let actns = map fromAction actionsOrCommands - - let importQualifiedSuggestion = "import qualified Control.Monad as Control" - importControlMonadQualified <- liftIO $ inspectCodeAction actionsOrCommands [importQualifiedSuggestion] - liftIO $ do - dontExpectCodeAction actionsOrCommands ["import Control.Monad (when)"] - length actns >= 5 @? "There are some actions" - - executeCodeAction importControlMonadQualified - - contents <- documentContents doc - liftIO $ contents @?= "import qualified Control.Monad as Control\nmain :: IO ()\nmain = Control.when True $ putStrLn \"hello\"\n" - ] - -importQualifiedPostTests :: TestTree -importQualifiedPostTests = testGroup "import qualified postfix suggestions" [ - testCase "qualified import in postfix position works with 3.8 code action kinds" $ runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "CodeActionImportPostQualified.hs" "haskell" - (diag:_) <- waitForDiagnosticsFrom doc - liftIO $ diag ^. L.message @?= - if ghcVersion >= GHC96 - then "Variable not in scope: Control.when :: Bool -> IO () -> IO ()\nNB: no module named ‘Control’ is imported." - else "Not in scope: ‘Control.when’\nNo module named ‘Control’ is imported." - - actionsOrCommands <- getAllCodeActions doc - let actns = map fromAction actionsOrCommands - - let importQualifiedPostSuggestion = "import Control.Monad qualified as Control" - importControlMonadQualified <- liftIO $ inspectCodeAction actionsOrCommands [importQualifiedPostSuggestion] - liftIO $ do - dontExpectCodeAction actionsOrCommands ["import qualified Control.Monad as Control", "import Control.Monad (when)"] - length actns >= 5 @? "There are some actions" - - executeCodeAction importControlMonadQualified - - contents <- documentContents doc - liftIO $ T.lines contents !! 2 @?= "import Control.Monad qualified as Control" - ] - -packageTests :: TestTree -packageTests = testGroup "add package suggestions" [ - ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to .cabal files" $ do - runSession hlsCommand fullCaps "test/testdata/addPackageTest/cabal-exe" $ do - doc <- openDoc "AddPackage.hs" "haskell" - - -- ignore the first empty hlint diagnostic publish - [_,diag:_] <- count 2 $ waitForDiagnosticsFrom doc - - let prefixes = [ "Could not load module `Data.Text'" -- Windows && GHC >= 8.6 - , "Could not find module `Data.Text'" -- Windows - , "Could not load module ‘Data.Text’" -- GHC >= 8.6 - , "Could not find module ‘Data.Text’" - ] - in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Contains prefix" - - acts <- getAllCodeActions doc - case acts of - (InR action:_) -> do - liftIO $ do - action ^. L.title @?= "Add text as a dependency" - action ^. L.kind @?= Just CodeActionKind_QuickFix - "package:add" `T.isSuffixOf` (action ^. L.command . _Just . L.command) @? "Command contains package:add" - - executeCodeAction action - - _ -> error $ "Unexpected code actions: " ++ show acts - - contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "add-package-test.cabal" - liftIO $ - any (\l -> "text -any" `T.isSuffixOf` l || "text : {} -any" `T.isSuffixOf` l) (T.lines contents) @? "Contains text package" - - , ignoreTestBecause "no support for adding dependent packages via code action" $ testCase "adds to hpack package.yaml files" $ - runSession hlsCommand fullCaps "test/testdata/addPackageTest/hpack-exe" $ do - doc <- openDoc "app/Asdf.hs" "haskell" - - -- ignore the first empty hlint diagnostic publish - [_,_:diag:_] <- count 2 $ waitForDiagnosticsFrom doc - - let prefixes = - [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6 - , "Could not find module `Codec.Compression.GZip'" -- Windows - , "Could not load module ‘Codec.Compression.GZip’" -- GHC >= 8.6 - , "Could not find module ‘Codec.Compression.GZip’" - ] - in liftIO $ any (`T.isPrefixOf` (diag ^. L.message)) prefixes @? "Diagnostic contains message" - - mActions <- getAllCodeActions doc - let allActions = map fromAction mActions - action <- case allActions of - (a:_) -> pure a - _ -> liftIO $ assertFailure "Expected non-empty list of actions" - - liftIO $ do - action ^. L.title @?= "Add zlib as a dependency" - forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionKind_QuickFix - forM_ allActions $ \a -> "package:add" `T.isSuffixOf` (a ^. L.command . _Just . L.command) @? "Command contains package:add" - - executeCodeAction action - - contents <- skipManyTill anyMessage $ getDocumentEdit . TextDocumentIdentifier =<< getDocUri "package.yaml" - liftIO $ do - "zlib" `T.isSuffixOf` (T.lines contents !! 3) @? "Contains zlib" - "zlib" `T.isSuffixOf` (T.lines contents !! 21) @? "Does not contain zlib in unrelated component" - ] - -redundantImportTests :: TestTree -redundantImportTests = testGroup "redundant import code actions" [ - testCase "remove solitary redundant imports" $ - runSession hlsCommand fullCaps "test/testdata/redundantImportTest/" $ do - doc <- openDoc "src/CodeActionRedundant.hs" "haskell" - - diags <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - liftIO $ expectDiagnostic diags [ "The import of", "Data.List", "is redundant" ] - liftIO $ expectDiagnostic diags [ "Empty", "from module", "Data.Sequence" ] - - mActions <- getAllCodeActions doc - - let allActions = map fromAction mActions - actionTitles = map (view L.title) allActions - - liftIO $ actionTitles `shouldContain` - [ "Remove import" - , "Remove Empty from import" - , "Remove all redundant imports" - ] - - let mbRemoveAction = find (\x -> x ^. L.title == "Remove all redundant imports") allActions - - case mbRemoveAction of - Just removeAction -> do - liftIO $ do - forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionKind_QuickFix - forM_ allActions $ \a -> a ^. L.command @?= Nothing - forM_ allActions $ \a -> isJust (a ^. L.edit) @? "Has edit" - - executeCodeAction removeAction - - Nothing -> error $ "Unexpected code actions: " ++ show allActions - - -- No command/applyworkspaceedit should be here, since action - -- provides workspace edit property which skips round trip to - -- the server - contents <- documentContents doc - liftIO $ contents @?= T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "{-# LANGUAGE PatternSynonyms #-}" - , "module CodeActionRedundant where" - , "-- We need a non-reduntant import in the import list" - , "-- to properly test the removal of the singular redundant item" - , "import Data.Sequence (singleton)" - , "main :: IO ()" - , "main = putStrLn \"hello\"" - , " where unused = Data.Sequence.singleton 42" - ] - - , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do - doc <- openDoc "src/MultipleImports.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - cmd <- liftIO $ inspectCommand cas ["redundant import"] - executeCommand cmd - _ <- anyRequest - contents <- documentContents doc - liftIO $ T.lines contents @?= - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module MultipleImports where" - , "import Data.Maybe" - , "foo :: Int" - , "foo = fromJust (Just 3)" - ] - ] - - -typedHoleTests :: TestTree -typedHoleTests = testGroup "typed hole code actions" [ - testCase "works" $ - runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "TypedHoles.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - liftIO $ do - expectCodeAction cas ["replace _ with minBound"] - expectCodeAction cas ["replace _ with foo _"] - replaceWithMaxBound <- liftIO $ inspectCodeAction cas ["replace _ with maxBound"] - - executeCodeAction replaceWithMaxBound - - contents <- documentContents doc - - liftIO $ contents @?= T.concat - [ "module TypedHoles where\n" - , "foo :: [Int] -> Int\n" - , "foo x = maxBound" - ] - - , testCase "shows more suggestions" $ - runSessionWithConfig (def {lspConfig = hlsConfigToClientConfig testConfig}) hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "TypedHoles2.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - - liftIO $ do - expectCodeAction cas ["replace _ with foo2 _"] - expectCodeAction cas ["replace _ with A _"] - replaceWithStuff <- liftIO $ inspectCodeAction cas ["replace _ with stuff _"] - - executeCodeAction replaceWithStuff - - contents <- documentContents doc - - liftIO $ T.lines contents @?= - [ "module TypedHoles2 (foo2) where" - , "newtype A = A Int" - , "foo2 :: [A] -> A" - , "foo2 x = (stuff _)" - , " where" - , " stuff (A a) = A (a + 1)" - ] - ] - -signatureTests :: TestTree -signatureTests = testGroup "missing top level signature code actions" [ - testCase "Adds top level signature" $ - runSession hlsCommand fullCaps "test/testdata/" $ do - doc <- openDoc "TopLevelSignature.hs" "haskell" - - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cas <- getAllCodeActions doc - - liftIO $ expectCodeAction cas ["add signature: main :: IO ()"] - - replaceWithStuff <- liftIO $ inspectCodeAction cas ["add signature"] - executeCodeAction replaceWithStuff - - contents <- documentContents doc - - let expected = [ "{-# OPTIONS_GHC -Wall #-}" - , "module TopLevelSignature where" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Hello\"" - , " return ()" - ] - - liftIO $ T.lines contents @?= expected - ] - -unusedTermTests :: TestTree -unusedTermTests = testGroup "unused term code actions" [ - ignoreTestBecause "no support for prefixing unused names with _" $ testCase "Prefixes with '_'" $ - runSession hlsCommand fullCaps "test/testdata/" $ do - doc <- openDoc "UnusedTerm.hs" "haskell" - - _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck) - cars <- getAllCodeActions doc - prefixImUnused <- liftIO $ inspectCodeAction cars ["Prefix imUnused with _"] - - executeCodeAction prefixImUnused - - edit <- skipManyTill anyMessage $ getDocumentEdit doc - - let expected = [ "{-# OPTIONS_GHC -Wall #-}" - , "module UnusedTerm () where" - , "_imUnused :: Int -> Int" - , "_imUnused 1 = 1" - , "_imUnused 2 = 2" - , "_imUnused _ = 3" - ] - - liftIO $ edit @?= T.unlines expected - - -- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction - -- `CodeActionContext` - , testCase "respect 'only' parameter" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "CodeActionOnly.hs" "haskell" - _ <- waitForDiagnosticsFrom doc - diags <- getCurrentDiagnostics doc - let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext - caContext = CodeActionContext diags (Just [CodeActionKind_Refactor]) Nothing - caContextAllActions = CodeActionContext diags Nothing Nothing - -- Verify that we get code actions of at least two different kinds. - TResponseMessage _ _ (Right res) - <- request SMethod_TextDocumentCodeAction (params & L.context .~ caContextAllActions) - liftIO $ do - let cas = map fromAction $ absorbNull res - kinds = map (^. L.kind) cas - assertBool "Test precondition failed" $ Just CodeActionKind_QuickFix `elem` kinds - -- Verify that that when we set the only parameter, we only get actions - -- of the right kind. - TResponseMessage _ _ (Right res) <- request SMethod_TextDocumentCodeAction params - liftIO $ do - let cas = map fromAction $ absorbNull res - kinds = map (^. L.kind) cas - assertBool "Quick fixes should have been filtered out" - $ Just CodeActionKind_QuickFix `notElem` kinds - ] - -testConfig :: Config -testConfig = def { - formattingProvider = "none" - } - - diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs deleted file mode 100644 --- a/test/functional/Highlight.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Highlight (tests) where - -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "highlight" [ - testCase "works" $ runSession (hlsCommand ++ " --test") fullCaps "test/testdata" $ do - doc <- openDoc "Highlight.hs" "haskell" - _ <- waitForDiagnosticsFrom doc - highlights <- getHighlights doc (Position 2 2) - liftIO $ do - let hls = - [ DocumentHighlight (mkRange 2 0 2 3) (Just DocumentHighlightKind_Write) - , DocumentHighlight (mkRange 4 22 4 25) (Just DocumentHighlightKind_Read) - , DocumentHighlight (mkRange 3 6 3 9) (Just DocumentHighlightKind_Read) - , DocumentHighlight (mkRange 1 0 1 3) (Just DocumentHighlightKind_Read)] - mapM_ (\x -> x `elem` highlights @? "Contains highlight") hls - ] - where - mkRange sl sc el ec = Range (Position sl sc) (Position el ec) diff --git a/test/functional/Main.hs b/test/functional/Main.hs --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -1,39 +1,17 @@ module Main where -import Command -import Completion import Config -import Deferred -import Definition -import Diagnostic import Format import FunctionalBadProject -import FunctionalCodeAction import HieBios -import Highlight import Progress -import Reference -import Symbol import Test.Hls -import TypeDefinition main :: IO () -main = defaultTestRunner - $ testGroup - "haskell-language-server" - [ Command.tests - , Completion.tests - , Config.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Deferred.tests - , Definition.tests - , Diagnostic.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests - , FunctionalBadProject.tests - , FunctionalCodeAction.tests - , HieBios.tests - , Highlight.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests - , Reference.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Symbol.tests - , TypeDefinition.tests - ] +main = defaultTestRunner $ testGroup "haskell-language-server" + [ Config.tests + , ignoreInEnv [HostOS Windows, GhcVer GHC90, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests + , FunctionalBadProject.tests + , HieBios.tests + , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests + ] diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -18,7 +18,6 @@ import Ide.Types import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L -import System.FilePath (()) import Test.Hls import Test.Hls.Command import Test.Hls.Flags @@ -29,10 +28,10 @@ testGroup "window/workDoneProgress" [ testCase "sends indefinite progress notifications" $ - runSession hlsCommand progressCaps "test/testdata" $ do - let path = "diagnostics" "Foo.hs" + runSession hlsCommand progressCaps "test/testdata/diagnostics" $ do + let path = "Foo.hs" _ <- openDoc path "haskell" - expectProgressMessages [pack ("Setting up testdata (for " ++ path ++ ")"), "Processing", "Indexing"] [] + expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs deleted file mode 100644 --- a/test/functional/Reference.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Reference (tests) where - -import Control.Lens -import Data.Coerce -import Data.List -import Language.LSP.Protocol.Lens -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "references" [ - ignoreTestBecause "Broken" $ testCase "works with definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "References.hs" "haskell" - let pos = Position 2 7 -- foo = bar <-- - refs <- getReferences doc pos True - liftIO $ map (Location (doc ^. uri)) [ - mkRange 4 0 4 3 - , mkRange 8 11 8 14 - , mkRange 7 7 7 10 - , mkRange 4 14 4 17 - , mkRange 4 0 4 3 - , mkRange 2 6 2 9 - ] `isInfixOf` coerce refs @? "Contains references" - -- TODO: Respect withDeclaration parameter - -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "References.hs" "haskell" - -- let pos = Position 2 7 -- foo = bar <-- - -- refs <- getReferences doc pos False - -- liftIO $ refs `shouldNotContain` [Location (doc ^. uri) (mkRange 4 0 4 3)] - ] - where mkRange sl sc el ec = Range (Position sl sc) (Position el ec) diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs deleted file mode 100644 --- a/test/functional/Symbol.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Symbol (tests) where - -import Control.Lens (_Just, ix, (^?)) -import Data.List -import Language.LSP.Protocol.Capabilities -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Test as Test -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "document symbols" [ - pre310Tests - , v310Tests - ] - -v310Tests :: TestTree -v310Tests = testGroup "3.10 hierarchical document symbols" [ - testCase "provides nested data types and constructors" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc - - let myData = DocumentSymbol "MyData" Nothing SymbolKind_Struct Nothing Nothing myDataR myDataSR (Just [a, b]) - a = DocumentSymbol "A" Nothing SymbolKind_Constructor Nothing Nothing aR aSR Nothing - b = DocumentSymbol "B" Nothing SymbolKind_Constructor Nothing Nothing bR bSR Nothing - let myData' = symbs ^? ix 0 . L.children . _Just . ix 2 - - liftIO $ Just myData == myData' @? "Contains symbol" - - , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc - - let foo = DocumentSymbol "foo" Nothing SymbolKind_Function Nothing Nothing fooR fooSR (Just [bar]) - bar = DocumentSymbol "bar" Nothing SymbolKind_Function Nothing Nothing barR barSR (Just [dog, cat]) - dog = DocumentSymbol "dog" Nothing SymbolKind_Variable Nothing Nothing dogR dogSR (Just mempty) - cat = DocumentSymbol "cat" Nothing SymbolKind_Variable Nothing Nothing catR catSR (Just mempty) - let foo' = symbs ^? ix 0 . L.children . _Just . ix 1 - - liftIO $ Just foo == foo' @? "Contains symbol" - - , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc - - let testPattern = DocumentSymbol "TestPattern" - Nothing SymbolKind_Function Nothing Nothing testPatternR testPatternSR (Just mempty) - let testPattern' = symbs ^? ix 0 . L.children . _Just . ix 3 - - liftIO $ Just testPattern == testPattern' @? "Contains symbol" - - , testCase "provides imports" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc - - let imports = DocumentSymbol "imports" Nothing SymbolKind_Module Nothing Nothing importsR importsSR (Just [importDataMaybe]) - importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SymbolKind_Module Nothing Nothing importDataMaybeR importDataMaybeSR Nothing - let imports' = symbs ^? ix 0 . L.children . _Just . ix 0 - - liftIO $ Just imports == imports' @? "Contains symbol" - ] - -pre310Tests :: TestTree -pre310Tests = testGroup "pre 3.10 symbol information" [ - testCase "provides nested data types and constructors" $ runSession hlsCommand oldCaps "test/testdata" $ do - doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc - - let myData = SymbolInformation "MyData" SymbolKind_Struct Nothing (Just "Symbols") Nothing (Location testUri myDataR) - a = SymbolInformation "A" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri aR) - b = SymbolInformation "B" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri bR) - - liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols" - - , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand oldCaps "test/testdata" $ do - doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc - - let foo = SymbolInformation "foo" SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri fooR) - bar = SymbolInformation "bar" SymbolKind_Function Nothing (Just "foo") Nothing (Location testUri barR) - dog = SymbolInformation "dog" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri dogR) - cat = SymbolInformation "cat" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri catR) - - -- Order is important! - liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols" - - , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand oldCaps "test/testdata" $ do - doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc - - let testPattern = SymbolInformation "TestPattern" - SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri testPatternR) - - liftIO $ testPattern `elem` symbs @? "Contains symbols" - - , testCase "provides imports" $ runSession hlsCommand oldCaps "test/testdata" $ do - doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc - - let imports = SymbolInformation "imports" SymbolKind_Module Nothing (Just "Symbols") Nothing (Location testUri importsR) - importDataMaybe = SymbolInformation "import Data.Maybe" SymbolKind_Module Nothing (Just "imports") Nothing (Location testUri importDataMaybeR) - - liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol" - ] - -oldCaps :: ClientCapabilities -oldCaps = capsForVersion (LSPVersion 3 9) - --- Some common ranges and selection ranges in Symbols.hs -importsR :: Range -importsR = Range (Position 3 0) (Position 3 17) -importsSR :: Range -importsSR = Range (Position 3 0) (Position 3 17) -importDataMaybeR :: Range -importDataMaybeR = Range (Position 3 0) (Position 3 17) -importDataMaybeSR :: Range -importDataMaybeSR = Range (Position 3 0) (Position 3 17) -fooSR :: Range -fooSR = Range (Position 5 0) (Position 7 43) -fooR :: Range -fooR = Range (Position 5 0) (Position 7 43) -barSR :: Range -barSR = Range (Position 6 8) (Position 6 11) -barR :: Range -barR = Range (Position 6 8) (Position 7 43) -dogSR :: Range -dogSR = Range (Position 7 17) (Position 7 20) -dogR :: Range -dogR = Range (Position 7 16) (Position 7 43) -catSR :: Range -catSR = Range (Position 7 22) (Position 7 25) -catR :: Range -catR = Range (Position 7 16) (Position 7 43) -myDataSR :: Range -myDataSR = Range (Position 9 0) (Position 10 22) -myDataR :: Range -myDataR = Range (Position 9 0) (Position 10 22) -aSR :: Range -aSR = Range (Position 9 14) (Position 9 15) -aR :: Range -aR = Range (Position 9 14) (Position 9 19) -bSR :: Range -bSR = Range (Position 10 14) (Position 10 15) -bR :: Range -bR = Range (Position 10 14) (Position 10 22) -testPatternSR :: Range -testPatternSR = Range (Position 13 8) (Position 13 19) -testPatternR :: Range -testPatternR = Range (Position 13 0) (Position 13 27) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs deleted file mode 100644 --- a/test/functional/TypeDefinition.hs +++ /dev/null @@ -1,42 +0,0 @@ -module TypeDefinition (tests) where - -import Data.Tuple.Extra (first3) -import System.FilePath (()) -import Test.Hls -import Test.Hls.Command - -tests :: TestTree -tests = testGroup "type definitions" [ - testCase "finds local definition of record variable" - $ getTypeDefinitionTest' 10 23 7 0 - , testCase "finds local definition of newtype variable" - $ getTypeDefinitionTest' 15 21 12 0 - , testCase "finds local definition of sum type variable" - $ getTypeDefinitionTest' 20 13 17 0 - , testCase "finds local definition of sum type constructor" - $ getTypeDefinitionTest' 23 7 17 0 - , testCase "finds non-local definition of type def" - $ getTypeDefinitionTest' 29 19 26 0 - , testCase "find local definition of type def" - $ getTypeDefinitionTest' 34 16 31 0 - , testCase "find type-definition of type def in component" - $ getTypeDefinitionTest ("src/Lib2.hs", 12, 20) [("src/Lib.hs", 7, 0)] - , testCase "find definition of parameterized data type" - $ getTypeDefinitionTest ("src/Lib.hs", 39, 19) [ ("src/Lib.hs", 36, 0) - , ("src/Lib.hs", 38, 0)] - ] - -definitionsPath :: FilePath -definitionsPath = "test/testdata/gototest" - -getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion -getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = - failIfSessionTimeout . runSession (hlsCommand ++ " --test") fullCaps definitionsPath $ do - doc <- openDoc symbolFile "haskell" - InL (Definition (InR defs)) <- getTypeDefinitions doc $ Position symbolLine symbolCol - liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations - -getTypeDefinitionTest' :: UInt -> UInt -> UInt -> UInt -> Assertion -getTypeDefinitionTest' symbolLine symbolCol definitionLine definitionCol = - getTypeDefinitionTest ("src/Lib.hs", symbolLine, symbolCol) - [("src/Lib.hs", definitionLine, definitionCol)] diff --git a/test/testdata/CodeActionImport.hs b/test/testdata/CodeActionImport.hs deleted file mode 100644 --- a/test/testdata/CodeActionImport.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = when True $ putStrLn "hello" diff --git a/test/testdata/CodeActionImportPostQualified.hs b/test/testdata/CodeActionImportPostQualified.hs deleted file mode 100644 --- a/test/testdata/CodeActionImportPostQualified.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# OPTIONS_GHC -Wprepositive-qualified-module #-} -main :: IO () -main = Control.when True $ putStrLn "hello" diff --git a/test/testdata/CodeActionImportQualified.hs b/test/testdata/CodeActionImportQualified.hs deleted file mode 100644 --- a/test/testdata/CodeActionImportQualified.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = Control.when True $ putStrLn "hello" diff --git a/test/testdata/CodeActionOnly.hs b/test/testdata/CodeActionOnly.hs deleted file mode 100644 --- a/test/testdata/CodeActionOnly.hs +++ /dev/null @@ -1,3 +0,0 @@ -module CodeActionOnly where -foo = bar - where bar = id Nothing diff --git a/test/testdata/CodeActionRename.hs b/test/testdata/CodeActionRename.hs deleted file mode 100644 --- a/test/testdata/CodeActionRename.hs +++ /dev/null @@ -1,2 +0,0 @@ -main = butStrLn "hello" -foo = putStrn "world" diff --git a/test/testdata/FuncTest.hs b/test/testdata/FuncTest.hs deleted file mode 100644 --- a/test/testdata/FuncTest.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -main = putStrLn "hello" - -foo :: Int -foo = bb - -bb = 5 - -baz = do - putStrLn "hello" - -f x = x+1 diff --git a/test/testdata/FuncTestError.hs b/test/testdata/FuncTestError.hs deleted file mode 100644 --- a/test/testdata/FuncTestError.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -main = putStrLn "hello" - -foo :: Int -foo = bb - -bb = 5 - -bug -- no hlint returned because of this, despite redundant do below - -baz = do - putStrLn "hello" - -f x = x+1 diff --git a/test/testdata/FuncTestFail.hs b/test/testdata/FuncTestFail.hs deleted file mode 100644 --- a/test/testdata/FuncTestFail.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO Int -main = return "yow diff --git a/test/testdata/Highlight.hs b/test/testdata/Highlight.hs deleted file mode 100644 --- a/test/testdata/Highlight.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Highlight where -foo :: Int -foo = 3 -bar = foo - where baz = let x = foo in id x diff --git a/test/testdata/Hover.hs b/test/testdata/Hover.hs deleted file mode 100644 --- a/test/testdata/Hover.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO Int -main = return $ sum [1,2,3] diff --git a/test/testdata/References.hs b/test/testdata/References.hs deleted file mode 100644 --- a/test/testdata/References.hs +++ /dev/null @@ -1,9 +0,0 @@ -main = return () - -foo = bar - -bar = let x = bar 42 in const "hello" - -baz = do - x <- bar 23 - return $ bar 14 diff --git a/test/testdata/Symbols.hs b/test/testdata/Symbols.hs deleted file mode 100644 --- a/test/testdata/Symbols.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Symbols where - -import Data.Maybe - -foo = bar - where bar = 42 + dog - where (dog, cat) = (1234, "meow") - -data MyData = A Int - | B String - -pattern TestPattern :: Int -> MyData -pattern TestPattern x = A x diff --git a/test/testdata/TopLevelSignature.hs b/test/testdata/TopLevelSignature.hs deleted file mode 100644 --- a/test/testdata/TopLevelSignature.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module TopLevelSignature where -main = do - putStrLn "Hello" - return () diff --git a/test/testdata/TypedHoles.hs b/test/testdata/TypedHoles.hs deleted file mode 100644 --- a/test/testdata/TypedHoles.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TypedHoles where -foo :: [Int] -> Int -foo x = _ diff --git a/test/testdata/TypedHoles2.hs b/test/testdata/TypedHoles2.hs deleted file mode 100644 --- a/test/testdata/TypedHoles2.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TypedHoles2 (foo2) where -newtype A = A Int -foo2 :: [A] -> A -foo2 x = _ - where - stuff (A a) = A (a + 1) diff --git a/test/testdata/UnusedTerm.hs b/test/testdata/UnusedTerm.hs deleted file mode 100644 --- a/test/testdata/UnusedTerm.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module UnusedTerm () where -imUnused :: Int -> Int -imUnused 1 = 1 -imUnused 2 = 2 -imUnused _ = 3 diff --git a/test/testdata/addPackageTest/cabal-exe/AddPackage.hs b/test/testdata/addPackageTest/cabal-exe/AddPackage.hs deleted file mode 100644 --- a/test/testdata/addPackageTest/cabal-exe/AddPackage.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Data.Text -foo = pack "I'm a Text" -main = putStrLn "hello" diff --git a/test/testdata/addPackageTest/cabal-exe/add-package-test.cabal b/test/testdata/addPackageTest/cabal-exe/add-package-test.cabal deleted file mode 100644 --- a/test/testdata/addPackageTest/cabal-exe/add-package-test.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: add-package-test -version: 0.1.0.0 -license: BSD3 -author: Luke Lau -maintainer: luke_lau@icloud.com -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 - -executable AddPackage - exposed-modules: ./. - main-is: AddPackage.hs - build-depends: base >=4.7 && <5 - default-language: Haskell2010 diff --git a/test/testdata/addPackageTest/cabal-lib/AddPackage.hs b/test/testdata/addPackageTest/cabal-lib/AddPackage.hs deleted file mode 100644 --- a/test/testdata/addPackageTest/cabal-lib/AddPackage.hs +++ /dev/null @@ -1,4 +0,0 @@ -module AddPackage where - -import Data.Text -foo = pack "I'm a Text" diff --git a/test/testdata/addPackageTest/cabal-lib/add-package-test.cabal b/test/testdata/addPackageTest/cabal-lib/add-package-test.cabal deleted file mode 100644 --- a/test/testdata/addPackageTest/cabal-lib/add-package-test.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: add-package-test -version: 0.1.0.0 -license: BSD3 -author: Luke Lau -maintainer: luke_lau@icloud.com -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 - -library - exposed-modules: AddPackage - build-depends: base >=4.7 && <5 - -- hs-source-dirs: - default-language: Haskell2010 diff --git a/test/testdata/addPackageTest/hpack-exe/app/Asdf.hs b/test/testdata/addPackageTest/hpack-exe/app/Asdf.hs deleted file mode 100644 --- a/test/testdata/addPackageTest/hpack-exe/app/Asdf.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Codec.Compression.GZip - -main = return $ compress "hello" diff --git a/test/testdata/addPackageTest/hpack-exe/asdf.cabal b/test/testdata/addPackageTest/hpack-exe/asdf.cabal deleted file mode 100644 --- a/test/testdata/addPackageTest/hpack-exe/asdf.cabal +++ /dev/null @@ -1,37 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.32.0. --- --- see: https://github.com/sol/hpack --- --- hash: 69241e1f4f912f034502d225d2017f035c38062080733108c11cd3d111cb9007 - -name: asdf -version: 0.1.0.0 -description: Please see the README on GitHub at -homepage: https://github.com/githubuser/asdf#readme -bug-reports: https://github.com/githubuser/asdf/issues -author: Author name here -maintainer: example@example.com -copyright: 2018 Author name here -license: BSD3 -build-type: Simple -extra-source-files: - README.md - ChangeLog.md - -source-repository head - type: git - location: https://github.com/githubuser/asdf - -executable asdf-exe - main-is: Main.hs - other-modules: - Asdf - Paths_asdf - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - default-language: Haskell2010 diff --git a/test/testdata/addPackageTest/hpack-lib/app/Asdf.hs b/test/testdata/addPackageTest/hpack-lib/app/Asdf.hs deleted file mode 100644 --- a/test/testdata/addPackageTest/hpack-lib/app/Asdf.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Asdf where - -import Codec.Compression.GZip - -main = return $ compress "hello" diff --git a/test/testdata/addPackageTest/invalid/AddPackage.hs b/test/testdata/addPackageTest/invalid/AddPackage.hs deleted file mode 100644 --- a/test/testdata/addPackageTest/invalid/AddPackage.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Data.Text -foo = pack "I'm a Text" diff --git a/test/testdata/badProjects/cabal/Foo.hs b/test/testdata/badProjects/cabal/Foo.hs deleted file mode 100644 --- a/test/testdata/badProjects/cabal/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -foo :: Int -foo = 3 diff --git a/test/testdata/badProjects/cabal/bad-cabal.cabal b/test/testdata/badProjects/cabal/bad-cabal.cabal deleted file mode 100644 --- a/test/testdata/badProjects/cabal/bad-cabal.cabal +++ /dev/null @@ -1,16 +0,0 @@ -name: bad-cabal -version: 0.1.0.0 -license: BSD3 -author: Alan Zimmerman -maintainer: alan.zimm@gmail.com -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 - -library - exposed-modules: Foo - build-depends: base >=4.7 && <5 - -- missing dependency - , does-not-exist - -- hs-source-dirs: - default-language: Haskell2010 diff --git a/test/testdata/completion/AssociatedTypeFamily.hs b/test/testdata/completion/AssociatedTypeFamily.hs deleted file mode 100644 --- a/test/testdata/completion/AssociatedTypeFamily.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module AssociatedTypeFamily () where - -class C a where - type Fam a - -x :: C a => a -> Fam a -x = undefined diff --git a/test/testdata/completion/Context.hs b/test/testdata/completion/Context.hs deleted file mode 100644 --- a/test/testdata/completion/Context.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Context where -import Control.Concurrent as Conc -foo :: Int -> Int -> Conc.MVar -foo x = abs 42 diff --git a/test/testdata/completion/DupRecFields.hs b/test/testdata/completion/DupRecFields.hs deleted file mode 100644 --- a/test/testdata/completion/DupRecFields.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module DupRecFields where - -newtype One = One { accessor :: Int } -newtype Two = Two { accessor :: Int } diff --git a/test/testdata/completion/FunctionCompletions.hs b/test/testdata/completion/FunctionCompletions.hs deleted file mode 100644 --- a/test/testdata/completion/FunctionCompletions.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Control.Applicative (Alternative) -import qualified Data.List - -main :: IO () -main = putStrLn "hello" - -foo :: Either a b -> Either a b -foo = id diff --git a/test/testdata/completion/RecordDotSyntax.hs b/test/testdata/completion/RecordDotSyntax.hs deleted file mode 100644 --- a/test/testdata/completion/RecordDotSyntax.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NoFieldSelectors #-} - -module Test where - -import qualified Data.Maybe as M - -data MyRecord = MyRecord1 - { a :: String - , b :: Integer - , c :: MyChild - } - | MyRecord2 { a2 :: String - , b2 :: Integer - , c2 :: MyChild - } deriving (Eq, Show) - -newtype MyChild = MyChild - { z :: String - } deriving (Eq, Show) - -x = MyRecord1 { a = "Hello", b = 12, c = MyChild { z = "there" } } - -y = x.a ++ show x.b - -y2 = x.c.z - diff --git a/test/testdata/completion/completions.cabal b/test/testdata/completion/completions.cabal deleted file mode 100644 --- a/test/testdata/completion/completions.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: completions -version: 0.1.0.0 -cabal-version: 2.0 -build-type: Simple - -executable compl-exe - other-modules: DupRecFields, Context - main-is: Completion.hs - default-language: Haskell2010 - build-depends: base diff --git a/test/testdata/completion/hie.yaml b/test/testdata/completion/hie.yaml --- a/test/testdata/completion/hie.yaml +++ b/test/testdata/completion/hie.yaml @@ -2,6 +2,4 @@ direct: arguments: - "Completion" - - "Context" - - "DupRecFields" - "FieldsSharingSignature" diff --git a/test/testdata/context/ExampleContext.hs b/test/testdata/context/ExampleContext.hs deleted file mode 100644 --- a/test/testdata/context/ExampleContext.hs +++ /dev/null @@ -1,20 +0,0 @@ -module ExampleContext (foo) where - -import Data.List (find) -import Control.Monad hiding (fix) - -foo :: Int -> Int -foo xs = bar xs + 1 - where - bar :: Int -> Int - bar x = x + 2 - -data Foo a = Foo a - deriving (Show) - -class Bar a where - bar :: a -> Integer - -instance Integral a => Bar (Foo a) where - bar (Foo a) = toInteger a - diff --git a/test/testdata/context/Foo/Bar.hs b/test/testdata/context/Foo/Bar.hs deleted file mode 100644 --- a/test/testdata/context/Foo/Bar.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Foo.Bar where - - diff --git a/test/testdata/definition/Bar.hs b/test/testdata/definition/Bar.hs deleted file mode 100644 --- a/test/testdata/definition/Bar.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Bar where - -a = 42 - --- These blank lines are here --- to ensure that b is defined --- on a line number larger than --- the number of lines in Foo.hs. -b = 43 diff --git a/test/testdata/definition/Foo.hs b/test/testdata/definition/Foo.hs deleted file mode 100644 --- a/test/testdata/definition/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo (module Bar) where - -import Bar - -fortyTwo = a -fortyThree = b diff --git a/test/testdata/definition/definitions.cabal b/test/testdata/definition/definitions.cabal deleted file mode 100644 --- a/test/testdata/definition/definitions.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: definitions -version: 0.1.0.0 -cabal-version: 2.0 -build-type: Simple - -library - exposed-modules: Foo - other-modules: Bar - default-language: Haskell2010 - build-depends: base diff --git a/test/testdata/definition/hie.yaml b/test/testdata/definition/hie.yaml deleted file mode 100644 --- a/test/testdata/definition/hie.yaml +++ /dev/null @@ -1,5 +0,0 @@ -cradle: - direct: - arguments: - - "Foo" - - "Bar" diff --git a/test/testdata/diagnostics/hie.yaml b/test/testdata/diagnostics/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/diagnostics/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - Foo + - -Wmissing-signatures diff --git a/test/testdata/format/hie.yaml b/test/testdata/format/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/format/hie.yaml @@ -0,0 +1,4 @@ +cradle: + direct: + arguments: + - Format diff --git a/test/testdata/gototest/hie.yaml b/test/testdata/gototest/hie.yaml deleted file mode 100644 --- a/test/testdata/gototest/hie.yaml +++ /dev/null @@ -1,6 +0,0 @@ -cradle: - direct: - arguments: - - "-i src/" - - "Lib" - - "Lib2" diff --git a/test/testdata/gototest/src/Lib.hs b/test/testdata/gototest/src/Lib.hs deleted file mode 100644 --- a/test/testdata/gototest/src/Lib.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Lib - - where - -someFunc :: IO () -someFunc = putStrLn "someFunc" - -data DataType = DataType Int - -dataTypeId :: DataType -> DataType -dataTypeId dataType = dataType - -newtype NewType = NewType Int - -newTypeId :: NewType -> NewType -newTypeId newType = newType - -data Enu = First | Second - -enuId :: Enu -> Enu -enuId enu = enu - -toNum :: Enu -> Int -toNum First = 1 -toNum Second = 2 - -type MyInt = Int - -myIntId :: MyInt -> MyInt -myIntId myInt = myInt - -type TypEnu = Enu - -typEnuId :: TypEnu -> TypEnu -typEnuId enu = enu - -data Parameter a = Parameter a - -parameterId :: Parameter a -> Parameter a -parameterId pid = pid diff --git a/test/testdata/gototest/src/Lib2.hs b/test/testdata/gototest/src/Lib2.hs deleted file mode 100644 --- a/test/testdata/gototest/src/Lib2.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Lib2 where - -import Lib - -g = do - someFunc - print x - where z = 1+2 - y = z+z - x = y*z - -otherId :: DataType -> DataType -otherId dataType = dataType diff --git a/test/testdata/hie.yaml b/test/testdata/hie.yaml deleted file mode 100644 --- a/test/testdata/hie.yaml +++ /dev/null @@ -1,12 +0,0 @@ -cradle: - direct: - arguments: - - "-Wmissing-signatures" - - "CodeActionImport" - - "CodeActionOnly" - - "CodeActionRename" - - "Highlight" - - "Symbols" - - "TopLevelSignature" - - "TypedHoles" - - "TypedHoles2" diff --git a/test/testdata/hieBiosMainIs/hie.yaml b/test/testdata/hieBiosMainIs/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/hieBiosMainIs/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/test/testdata/liquid/Evens.hs b/test/testdata/liquid/Evens.hs deleted file mode 100644 --- a/test/testdata/liquid/Evens.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main where - -{-@ type Even = {v:Int | v mod 2 = 0} @-} - -{-@ weAreEven :: [Even] @-} -weAreEven = [(0-10), (0-4), 0, 2, 666] - -{-@ notEven :: Even @-} -notEven = 7 - -{-@ isEven :: n:Nat -> {v:Bool | (v <=> (n mod 2 == 0))} @-} -isEven :: Int -> Bool -isEven 0 = True -isEven 1 = False -isEven n = not (isEven (n-1)) - -{-@ evens :: n:Nat -> [Even] @-} -evens n = [i | i <- range 0 n, isEven i] - -{-@ range :: lo:Int -> hi:Int -> [{v:Int | (lo <= v && v < hi)}] / [hi -lo] @-} -range lo hi - | lo < hi = lo : range (lo+1) hi - | otherwise = [] - -{-@ shift :: [Even] -> Even -> [Even] @-} -shift xs k = [x + k | x <- xs] - -{-@ double :: [Nat] -> [Even] @-} -double xs = [x + x | x <- xs] - - - ---- - -notEven :: Int -weAreEven :: [Int] -shift :: [Int] -> Int -> [Int] -double :: [Int] -> [Int] -range :: Int -> Int -> [Int] - -main = putStrLn "hello" diff --git a/test/testdata/redundantImportTest/hie.yaml b/test/testdata/redundantImportTest/hie.yaml deleted file mode 100644 --- a/test/testdata/redundantImportTest/hie.yaml +++ /dev/null @@ -1,5 +0,0 @@ -cradle: - direct: - arguments: - - "src/CodeActionRedundant" - - "src/MultipleImports" diff --git a/test/testdata/redundantImportTest/src/CodeActionRedundant.hs b/test/testdata/redundantImportTest/src/CodeActionRedundant.hs deleted file mode 100644 --- a/test/testdata/redundantImportTest/src/CodeActionRedundant.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE PatternSynonyms #-} -module CodeActionRedundant where -import Data.List --- We need a non-reduntant import in the import list --- to properly test the removal of the singular redundant item -import Data.Sequence (pattern Empty, singleton) -main :: IO () -main = putStrLn "hello" - where unused = Data.Sequence.singleton 42 diff --git a/test/testdata/redundantImportTest/src/MultipleImports.hs b/test/testdata/redundantImportTest/src/MultipleImports.hs deleted file mode 100644 --- a/test/testdata/redundantImportTest/src/MultipleImports.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} -module MultipleImports where -import Data.Foldable -import Data.Maybe -foo :: Int -foo = fromJust (Just 3) diff --git a/test/testdata/redundantImportTest/test.cabal b/test/testdata/redundantImportTest/test.cabal deleted file mode 100644 --- a/test/testdata/redundantImportTest/test.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: test -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: CodeActionRedundant, MultipleImports - hs-source-dirs: src - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall -fwarn-unused-imports diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal deleted file mode 100644 --- a/test/testdata/testdata.cabal +++ /dev/null @@ -1,37 +0,0 @@ -name: testdata -version: 0.1.0.0 -cabal-version: 2.0 -build-type: Simple - -executable codeactionrename - build-depends: base - main-is: CodeActionRename.hs - default-language: Haskell2010 - -executable codeactiononly - build-depends: base - main-is: CodeActionOnly.hs - default-language: Haskell2010 - - - -executable hover - build-depends: base - main-is: Hover.hs - default-language: Haskell2010 - -executable symbols - build-depends: base - main-is: Symbols.hs - default-language: Haskell2010 - -executable functests - build-depends: base - main-is: FuncTest.hs - default-language: Haskell2010 - -executable evens - build-depends: base - main-is: Evens.hs - hs-source-dirs: liquid - default-language: Haskell2010 diff --git a/test/testdata/wErrorTest/cabal.project b/test/testdata/wErrorTest/cabal.project deleted file mode 100644 --- a/test/testdata/wErrorTest/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: test.cabal diff --git a/test/testdata/wErrorTest/hie.yaml b/test/testdata/wErrorTest/hie.yaml deleted file mode 100644 --- a/test/testdata/wErrorTest/hie.yaml +++ /dev/null @@ -1,4 +0,0 @@ -cradle: - cabal: - - path: "src" - component: "lib:test" diff --git a/test/testdata/wErrorTest/src/WError.hs b/test/testdata/wErrorTest/src/WError.hs deleted file mode 100644 --- a/test/testdata/wErrorTest/src/WError.hs +++ /dev/null @@ -1,3 +0,0 @@ -module WError where -{-# ANN module "HLint: ignore" #-} -main = undefined diff --git a/test/testdata/wErrorTest/test.cabal b/test/testdata/wErrorTest/test.cabal deleted file mode 100644 --- a/test/testdata/wErrorTest/test.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: test -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: WError - hs-source-dirs: src - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 - ghc-options: -Wall -Werror diff --git a/test/utils/Test/Hls/Command.hs b/test/utils/Test/Hls/Command.hs --- a/test/utils/Test/Hls/Command.hs +++ b/test/utils/Test/Hls/Command.hs @@ -1,19 +1,12 @@ module Test.Hls.Command - ( hlsCommand, - hlsCommandExamplePlugin, - hlsCommandVomit, - logFilePath, + ( hlsCommand ) where import Data.Maybe (fromMaybe) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) -import Test.Hls -logFilePath :: String -logFilePath = "hls-" ++ show ghcVersion ++ ".log" - -- | The command to execute the version of hls for the current compiler. -- -- Both @stack test@ and @cabal new-test@ setup the environment so @hls@ is @@ -24,9 +17,3 @@ hlsCommand = unsafePerformIO $ do testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE" pure $ testExe ++ " --lsp -d -j4" - -hlsCommandVomit :: String -hlsCommandVomit = hlsCommand ++ " --vomit" - -hlsCommandExamplePlugin :: String -hlsCommandExamplePlugin = hlsCommand ++ " --example"