From 20a37ece9e148cc26ff589336a9ad49fa6a094ee Mon Sep 17 00:00:00 2001 From: Jiri Lojda Date: Fri, 17 Nov 2023 10:33:25 +0100 Subject: [PATCH] Merge definitions from all plugins for Document(Type)Definition message (#3846) * Merge definitions from all plugins for Document(Type)Definition message - enables multiple plugins to provide Document(Type)Definition for the same message * Remove unnecessary head usage in ghcide TestUtils * Use Nothing for original selection when upgrading Location to LocationLink in combineResponses of plugins to TextDocumentDefinition message * Share combineResponses document definition and document type definition tests * Downgrade locations to links when missing client capability in combineResponses (plugin API) - Upgrade locations to links only when necessary (some responses are links) * Test preserving link data in combineResponses of Definition message * Add haddock to mergeDefinitions in plugin API * Replace usage of OverloadedRecordDot with lenses - to support GHC < 9.2 * Add TypeFamilies extension to TypesTests to support GHC < 9.4 * Require focus >= 1.0.3.2 to fix 9.8 build for ghcide and hls-graph --------- Co-authored-by: Michael Peyton Jones --- ghcide/ghcide.cabal | 838 +++++++++++++------------- ghcide/test/exe/TestUtils.hs | 17 +- hls-graph/hls-graph.cabal | 92 +-- hls-plugin-api/hls-plugin-api.cabal | 35 +- hls-plugin-api/src/Ide/Types.hs | 54 +- hls-plugin-api/test/Ide/TypesTests.hs | 245 ++++++++ hls-plugin-api/test/Main.hs | 2 + 7 files changed, 793 insertions(+), 490 deletions(-) create mode 100644 hls-plugin-api/test/Ide/TypesTests.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7f8c850884..5e475da931 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -9,447 +9,451 @@ author: Digital Asset and Ghcide contributors maintainer: Ghcide contributors copyright: Digital Asset and Ghcide contributors 2018-2020 synopsis: The core of an IDE -description: - A library for building Haskell IDE's on top of the GHC API. -homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme +description: A library for building Haskell IDE's on top of the GHC API. +homepage: + https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme + bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 9.0.2 || == 9.2.5 -extra-source-files: README.md CHANGELOG.md - test/data/**/*.project - test/data/**/*.cabal - test/data/**/*.yaml - test/data/**/*.hs - test/data/**/*.hs-boot +tested-with: GHC ==9.0.2 || ==9.2.5 +extra-source-files: + CHANGELOG.md + README.md + test/data/**/*.cabal + test/data/**/*.hs + test/data/**/*.hs-boot + test/data/**/*.project + test/data/**/*.yaml source-repository head - type: git - location: https://github.com/haskell/haskell-language-server.git + type: git + location: https://github.com/haskell/haskell-language-server.git flag ghc-patched-unboxed-bytecode - description: The GHC version we link against supports unboxed sums and tuples in bytecode - default: False - manual: True + description: + The GHC version we link against supports unboxed sums and tuples in bytecode + + default: False + manual: True flag ekg - description: Enable EKG monitoring of the build graph and other metrics on port 8999 - default: False - manual: True + description: + Enable EKG monitoring of the build graph and other metrics on port 8999 + + default: False + manual: True flag pedantic - description: Enable -Werror - default: False - manual: True + description: Enable -Werror + default: False + manual: True library - default-language: Haskell2010 - build-depends: - aeson, - array, - async, - base == 4.*, - binary, - bytestring, - case-insensitive, - co-log-core, - containers, - data-default, - deepseq, - directory, - dependent-map, - dependent-sum, - dlist, - exceptions, - extra >= 1.7.14, - enummapset, - filepath, - fingertree, - focus, - ghc-trace-events, - Glob, - haddock-library >= 1.8 && < 1.12, - hashable, - hie-compat ^>= 0.3.0.0, - hls-plugin-api == 2.4.0.0, - lens, - list-t, - hiedb == 0.4.4.*, - lsp-types ^>= 2.1.0.0, - lsp ^>= 2.3.0.0 , - mtl, - optparse-applicative, - parallel, - prettyprinter-ansi-terminal, - prettyprinter >= 1.7, - random, - regex-tdfa >= 1.3.1.0, - row-types, - text-rope, - safe-exceptions, - hls-graph == 2.4.0.0, - sorted-list, - sqlite-simple, - stm, - stm-containers, - syb, - text, - time, - transformers, - unordered-containers >= 0.2.10.0, - vector, - Diff ^>=0.4.0, - vector, - opentelemetry >=0.6.1, - unliftio >= 0.2.6, - unliftio-core, - ghc-boot-th, - ghc-boot, - ghc >= 9.0, - ghc-check >=0.5.0.8, - ghc-paths, - cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios == 0.12.1, - -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change. - -- https://github.com/Avi-D-coder/implicit-hie/issues/50 - -- to make sure ghcide behaves in a desirable way, we put implicit-hie - -- fake dependency here. - implicit-hie < 0.1.3, - implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, - base16-bytestring >=0.1.1 && <1.1 - if os(windows) - build-depends: - Win32 - else - build-depends: - unix - - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - DeriveFoldable - DeriveTraversable - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - DataKinds - TypeOperators - KindSignatures - - hs-source-dirs: - src - session-loader - exposed-modules: - Control.Concurrent.Strict - Generics.SYB.GHC - Development.IDE - Development.IDE.Main - Development.IDE.Core.Actions - Development.IDE.Main.HeapStats - Development.IDE.Core.Debouncer - Development.IDE.Core.FileStore - Development.IDE.Core.FileUtils - Development.IDE.Core.IdeConfiguration - Development.IDE.Core.OfInterest - Development.IDE.Core.PluginUtils - Development.IDE.Core.PositionMapping - Development.IDE.Core.Preprocessor - Development.IDE.Core.ProgressReporting - Development.IDE.Core.Rules - Development.IDE.Core.RuleTypes - Development.IDE.Core.Service - Development.IDE.Core.Shake - Development.IDE.Core.Tracing - Development.IDE.Core.UseStale - Development.IDE.GHC.Compat - Development.IDE.GHC.Compat.Core - Development.IDE.GHC.Compat.Env - Development.IDE.GHC.Compat.Iface - Development.IDE.GHC.Compat.Logger - Development.IDE.GHC.Compat.Outputable - Development.IDE.GHC.Compat.Parser - Development.IDE.GHC.Compat.Plugins - Development.IDE.GHC.Compat.Units - Development.IDE.GHC.Compat.Util - Development.IDE.Core.Compile - Development.IDE.GHC.CoreFile - Development.IDE.GHC.Error - Development.IDE.GHC.Orphans - Development.IDE.GHC.Util - Development.IDE.Import.DependencyInformation - Development.IDE.Import.FindImports - Development.IDE.Monitoring.EKG - Development.IDE.LSP.HoverDefinition - Development.IDE.LSP.LanguageServer - Development.IDE.LSP.Notifications - Development.IDE.LSP.Outline - Development.IDE.LSP.Server - Development.IDE.Session - Development.IDE.Session.Diagnostics - Development.IDE.Spans.Common - Development.IDE.Spans.Documentation - Development.IDE.Spans.AtPoint - Development.IDE.Spans.LocalBindings - Development.IDE.Spans.Pragmas - Development.IDE.Types.Diagnostics - Development.IDE.Types.Exports - Development.IDE.Types.HscEnvEq - Development.IDE.Types.KnownTargets - Development.IDE.Types.Location - Development.IDE.Types.Monitoring - Development.IDE.Monitoring.OpenTelemetry - Development.IDE.Types.Options - Development.IDE.Types.Shake - Development.IDE.Plugin - Development.IDE.Plugin.Completions - Development.IDE.Plugin.Completions.Types - Development.IDE.Plugin.HLS - Development.IDE.Plugin.HLS.GhcIde - Development.IDE.Plugin.Test - Development.IDE.Plugin.TypeLenses - Text.Fuzzy.Parallel - - other-modules: - Development.IDE.Core.FileExists - Development.IDE.GHC.CPP - Development.IDE.GHC.Warnings - Development.IDE.Plugin.Completions.Logic - Development.IDE.Session.VersionCheck - Development.IDE.Types.Action + default-language: Haskell2010 + build-depends: + , aeson + , array + , async + , base >=4 && <5 + , base16-bytestring >=0.1.1 && <1.1 + , binary + , bytestring + , case-insensitive + , co-log-core + , containers + , cryptohash-sha1 >=0.11.100 && <0.12 + , data-default + , deepseq + , dependent-map + , dependent-sum + , Diff ^>=0.4.0 + , directory + , dlist + , enummapset + , exceptions + , extra >=1.7.14 + , filepath + , fingertree + , focus >=1.0.3.2 + , ghc >=9.0 + , ghc-boot + , ghc-boot-th + , ghc-check >=0.5.0.8 + , ghc-paths + , ghc-trace-events + , Glob + , haddock-library >=1.8 && <1.12 + , hashable + , hie-bios ==0.12.1 + , hie-compat ^>=0.3.0.0 + , hiedb >=0.4.4 && <0.4.5 + , hls-graph ==2.4.0.0 + , hls-plugin-api ==2.4.0.0 + , implicit-hie <0.1.3 + , implicit-hie-cradle ^>=0.3.0.5 || ^>=0.5 + , lens + , list-t + , lsp ^>=2.3.0.0 + , lsp-types ^>=2.1.0.0 + , mtl + , opentelemetry >=0.6.1 + , optparse-applicative + , parallel + , prettyprinter >=1.7 + , prettyprinter-ansi-terminal + , random + , regex-tdfa >=1.3.1.0 + , row-types + , safe-exceptions + , sorted-list + , sqlite-simple + , stm + , stm-containers + , syb + , text + , text-rope + , time + , transformers + , unliftio >=0.2.6 + , unliftio-core + , unordered-containers >=0.2.10.0 + , vector + + -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change. + -- https://github.com/Avi-D-coder/implicit-hie/issues/50 + -- to make sure ghcide behaves in a desirable way, we put implicit-hie + -- fake dependency here. + if os(windows) + build-depends: Win32 + + else + build-depends: unix + + default-extensions: + BangPatterns + DataKinds + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + FlexibleContexts + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + ViewPatterns + + hs-source-dirs: src session-loader + exposed-modules: + Control.Concurrent.Strict + Development.IDE + Development.IDE.Core.Actions + Development.IDE.Core.Compile + Development.IDE.Core.Debouncer + Development.IDE.Core.FileStore + Development.IDE.Core.FileUtils + Development.IDE.Core.IdeConfiguration + Development.IDE.Core.OfInterest + Development.IDE.Core.PluginUtils + Development.IDE.Core.PositionMapping + Development.IDE.Core.Preprocessor + Development.IDE.Core.ProgressReporting + Development.IDE.Core.Rules + Development.IDE.Core.RuleTypes + Development.IDE.Core.Service + Development.IDE.Core.Shake + Development.IDE.Core.Tracing + Development.IDE.Core.UseStale + Development.IDE.GHC.Compat + Development.IDE.GHC.Compat.Core + Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.Iface + Development.IDE.GHC.Compat.Logger + Development.IDE.GHC.Compat.Outputable + Development.IDE.GHC.Compat.Parser + Development.IDE.GHC.Compat.Plugins + Development.IDE.GHC.Compat.Units + Development.IDE.GHC.Compat.Util + Development.IDE.GHC.CoreFile + Development.IDE.GHC.Error + Development.IDE.GHC.Orphans + Development.IDE.GHC.Util + Development.IDE.Import.DependencyInformation + Development.IDE.Import.FindImports + Development.IDE.LSP.HoverDefinition + Development.IDE.LSP.LanguageServer + Development.IDE.LSP.Notifications + Development.IDE.LSP.Outline + Development.IDE.LSP.Server + Development.IDE.Main + Development.IDE.Main.HeapStats + Development.IDE.Monitoring.EKG + Development.IDE.Monitoring.OpenTelemetry + Development.IDE.Plugin + Development.IDE.Plugin.Completions + Development.IDE.Plugin.Completions.Types + Development.IDE.Plugin.HLS + Development.IDE.Plugin.HLS.GhcIde + Development.IDE.Plugin.Test + Development.IDE.Plugin.TypeLenses + Development.IDE.Session + Development.IDE.Session.Diagnostics + Development.IDE.Spans.AtPoint + Development.IDE.Spans.Common + Development.IDE.Spans.Documentation + Development.IDE.Spans.LocalBindings + Development.IDE.Spans.Pragmas + Development.IDE.Types.Diagnostics + Development.IDE.Types.Exports + Development.IDE.Types.HscEnvEq + Development.IDE.Types.KnownTargets + Development.IDE.Types.Location + Development.IDE.Types.Monitoring + Development.IDE.Types.Options + Development.IDE.Types.Shake + Generics.SYB.GHC + Text.Fuzzy.Parallel + other-modules: + Development.IDE.Core.FileExists + Development.IDE.GHC.CPP + Development.IDE.GHC.Warnings + Development.IDE.Plugin.Completions.Logic + Development.IDE.Session.VersionCheck + Development.IDE.Types.Action + + ghc-options: + -Wall -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors + -Wunused-packages -fno-ignore-asserts + + if flag(ghc-patched-unboxed-bytecode) + cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + + if flag(pedantic) + -- We eventually want to build with Werror fully, but we haven't + -- finished purging the warnings, so some are set to not be errors + -- for now ghc-options: - -Wall - -Wincomplete-uni-patterns - -Wno-unticked-promoted-constructors - -Wunused-packages - -fno-ignore-asserts - - if flag(ghc-patched-unboxed-bytecode) - cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE - - if flag(pedantic) - -- We eventually want to build with Werror fully, but we haven't - -- finished purging the warnings, so some are set to not be errors - -- for now - ghc-options: -Werror - -Wwarn=unused-packages - -Wwarn=unrecognised-pragmas - -Wwarn=dodgy-imports - -Wwarn=missing-signatures - -Wwarn=duplicate-exports - -Wwarn=dodgy-exports - -Wwarn=incomplete-patterns - -Wwarn=overlapping-patterns - -Wwarn=incomplete-record-updates - - -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it - -- then. The above comment goes for here too -- this should be understood to - -- be temporary until we can remove these warnings. - if impl(ghc >= 9.2) && flag(pedantic) - ghc-options: -Wwarn=ambiguous-fields - - if flag(ekg) - build-depends: - ekg-wai, - ekg-core, - cpp-options: -DMONITORING_EKG + -Werror -Wwarn=unused-packages -Wwarn=unrecognised-pragmas + -Wwarn=dodgy-imports -Wwarn=missing-signatures + -Wwarn=duplicate-exports -Wwarn=dodgy-exports + -Wwarn=incomplete-patterns -Wwarn=overlapping-patterns + -Wwarn=incomplete-record-updates + + -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it + -- then. The above comment goes for here too -- this should be understood to + -- be temporary until we can remove these warnings. + if (impl(ghc >=9.2) && flag(pedantic)) + ghc-options: -Wwarn=ambiguous-fields + + if flag(ekg) + build-depends: + , ekg-core + , ekg-wai + + cpp-options: -DMONITORING_EKG flag test-exe - description: Build the ghcide-test-preprocessor executable - default: True + description: Build the ghcide-test-preprocessor executable + default: True executable ghcide-test-preprocessor - default-language: Haskell2010 - hs-source-dirs: test/preprocessor - ghc-options: -Wall -Wno-name-shadowing - main-is: Main.hs - build-depends: - base == 4.* + default-language: Haskell2010 + hs-source-dirs: test/preprocessor + ghc-options: -Wall -Wno-name-shadowing + main-is: Main.hs + build-depends: base >=4 && <5 - if !flag(test-exe) - buildable: False + if !flag(test-exe) + buildable: False flag executable - description: Build the ghcide executable - default: True + description: Build the ghcide executable + default: True executable ghcide - default-language: Haskell2010 - hs-source-dirs: exe - ghc-options: - -threaded - -Wall - -Wincomplete-uni-patterns - -Wno-name-shadowing - -- allow user RTS overrides - -rtsopts - -- disable idle GC - -- increase nursery size - -- Enable collection of heap statistics - "-with-rtsopts=-I0 -A128M -T" - main-is: Main.hs + default-language: Haskell2010 + hs-source-dirs: exe + ghc-options: + -threaded -Wall -Wincomplete-uni-patterns -Wno-name-shadowing + -rtsopts "-with-rtsopts=-I0 -A128M -T" + + -- allow user RTS overrides + -- disable idle GC + -- increase nursery size + -- Enable collection of heap statistics + main-is: Main.hs + build-depends: + , base >=4 && <5 + , data-default + , extra + , ghcide + , gitrev + , hls-plugin-api + , lsp + , lsp-types + , optparse-applicative + + other-modules: + Arguments + Paths_ghcide + + autogen-modules: Paths_ghcide + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + + if !flag(executable) + buildable: False + + if flag(ekg) build-depends: - base == 4.*, - data-default, - extra, - gitrev, - lsp, - lsp-types, - hls-plugin-api, - ghcide, - optparse-applicative, - other-modules: - Arguments - Paths_ghcide - autogen-modules: - Paths_ghcide - - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - - if !flag(executable) - buildable: False - if flag(ekg) - build-depends: - ekg-wai, - ekg-core, - cpp-options: -DMONITORING_EKG - if impl(ghc >= 9) - ghc-options: -Wunused-packages + , ekg-core + , ekg-wai + cpp-options: -DMONITORING_EKG + + if impl(ghc >=9) + ghc-options: -Wunused-packages test-suite ghcide-tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide, - ghcide:ghcide-test-preprocessor, - implicit-hie:gen-hie + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-tool-depends: + , ghcide:ghcide + , ghcide:ghcide-test-preprocessor + , implicit-hie:gen-hie + + build-depends: + , aeson + , async + , base + , containers + , data-default + , directory + , extra + , filepath + , fuzzy + , ghc + , ghcide + , hls-plugin-api + , lens + , list-t + , lsp + , lsp-test ^>=0.16.0.0 + , lsp-types + , monoid-subclasses + , mtl + , network-uri + , QuickCheck + , random + , regex-tdfa ^>=1.3.1 + , row-types + , shake + , sqlite-simple + , stm + , stm-containers + , tasty + , tasty-expected-failure + , tasty-hunit >=0.10 + , tasty-quickcheck + , tasty-rerun + , text + , text-rope + , unordered-containers + + -------------------------------------------------------------- + -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas + -- which require depending on ghc. So the tests need to depend + -- on ghc if they need to use MIN_VERSION_ghc. Maybe a + -- better solution can be found, but this is a quick solution + -- which works for now. + -------------------------------------------------------------- + if impl(ghc <9.2) build-depends: - aeson, - async, - base, - containers, - data-default, - directory, - extra, - filepath, - fuzzy, - -------------------------------------------------------------- - -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas - -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_VERSION_ghc. Maybe a - -- better solution can be found, but this is a quick solution - -- which works for now. - ghc, - -------------------------------------------------------------- - ghcide, - lsp, - lsp-types, - hls-plugin-api, - lens, - list-t, - lsp-test ^>= 0.16.0.0, - mtl, - monoid-subclasses, - network-uri, - QuickCheck, - random, - regex-tdfa ^>= 1.3.1, - shake, - sqlite-simple, - stm, - stm-containers, - tasty, - tasty-expected-failure, - tasty-hunit >= 0.10, - tasty-quickcheck, - tasty-rerun, - text, - text-rope, - unordered-containers, - row-types - if impl(ghc < 9.2) - build-depends: - record-dot-preprocessor, - record-hasfield - if impl(ghc < 9.3) - build-depends: ghc-typelits-knownnat - hs-source-dirs: test/cabal test/exe test/src - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors -Wunused-packages - main-is: Main.hs - other-modules: - Development.IDE.Test.Runfiles - FuzzySearch - Progress - HieDbRetry - Development.IDE.Test - Development.IDE.Test.Diagnostic - ExceptionTests - -- Tests that have been pulled out of the main file - BootTests - CodeLensTests - CompletionTests - CPPTests - CradleTests - DependentFileTest - DiagnosticTests - FindDefinitionAndHoverTests - HaddockTests - HighlightTests - IfaceTests - InitializeResponseTests - LogType - NonLspCommandLine - OutlineTests - PluginParsedResultTests - PluginSimpleTests - PositionMappingTests - PreprocessorTests - RootUriTests - SafeTests - SymlinkTests - TestUtils - THTests - UnitTests - WatchedFileTests - AsyncTests - ClientSettingsTests - ReferenceTests - GarbageCollectionTests - OpenCloseTest - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns + , record-dot-preprocessor + , record-hasfield + + if impl(ghc <9.3) + build-depends: ghc-typelits-knownnat + + hs-source-dirs: test/cabal test/exe test/src + ghc-options: + -threaded -Wall -Wno-name-shadowing -O0 + -Wno-unticked-promoted-constructors -Wunused-packages + + main-is: Main.hs + other-modules: + AsyncTests + BootTests + ClientSettingsTests + CodeLensTests + CompletionTests + CPPTests + CradleTests + DependentFileTest + Development.IDE.Test + Development.IDE.Test.Diagnostic + Development.IDE.Test.Runfiles + DiagnosticTests + ExceptionTests + FindDefinitionAndHoverTests + FuzzySearch + GarbageCollectionTests + HaddockTests + HieDbRetry + HighlightTests + IfaceTests + InitializeResponseTests + LogType + NonLspCommandLine + OpenCloseTest + OutlineTests + PluginParsedResultTests + PluginSimpleTests + PositionMappingTests + PreprocessorTests + Progress + ReferenceTests + RootUriTests + SafeTests + SymlinkTests + TestUtils + THTests + UnitTests + WatchedFileTests + + -- Tests that have been pulled out of the main file + default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 7ecd765e10..676cad1b34 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -210,7 +210,7 @@ knownIssueFor solution = go . \case go True = case solution of Broken -> expectFailBecause Ignore -> ignoreTestBecause - go False = \_ -> id + go False = const id data Expect = ExpectRange Range -- Both gotoDef and hover should report this range @@ -278,21 +278,22 @@ pattern R x y x' y' = Range (Position x y) (Position x' y') checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange + def <- assertOneDefinitionFound defs + assertRangeCorrect def expectedRange check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs + def <- assertOneDefinitionFound defs liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) + canonActualLoc <- canonicalizeLocation def canonExpectedLoc <- canonicalizeLocation expectedLocation canonActualLoc @?= canonExpectedLoc check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs + liftIO $ assertBool "Expecting no definitions" $ null defs check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" check _ = pure () -- all other expectations not relevant to getDefinition - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + assertOneDefinitionFound :: [Location] -> Session Location + assertOneDefinitionFound [def] = pure def + assertOneDefinitionFound _ = liftIO $ assertFailure "Expecting exactly one definition" assertRangeCorrect Location{_range = foundRange} expectedRange = liftIO $ expectedRange @=? foundRange diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 21130e76c5..740baf6227 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -1,25 +1,24 @@ -cabal-version: 2.4 -name: hls-graph -version: 2.4.0.0 -synopsis: Haskell Language Server internal graph API +cabal-version: 2.4 +name: hls-graph +version: 2.4.0.0 +synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at -homepage: https://github.com/haskell/haskell-language-server#readme -bug-reports: https://github.com/haskell/haskell-language-server/issues -license: Apache-2.0 -license-file: LICENSE -author: The Haskell IDE Team -maintainer: The Haskell IDE Team -copyright: The Haskell IDE Team -category: Development -build-type: Simple +homepage: https://github.com/haskell/haskell-language-server#readme +bug-reports: https://github.com/haskell/haskell-language-server/issues +license: Apache-2.0 +license-file: LICENSE +author: The Haskell IDE Team +maintainer: The Haskell IDE Team +copyright: The Haskell IDE Team +category: Development +build-type: Simple data-files: - html/profile.html - html/shake.js + html/profile.html + html/shake.js -extra-source-files: - README.md +extra-source-files: README.md flag pedantic description: Enable -Werror @@ -27,13 +26,13 @@ flag pedantic manual: True flag embed-files - default: False - manual: True + default: False + manual: True description: Embed data files into the shake library flag stm-stats - default: False - manual: True + default: False + manual: True description: Collect STM transaction stats source-repository head @@ -46,25 +45,24 @@ library Development.IDE.Graph Development.IDE.Graph.Classes Development.IDE.Graph.Database - Development.IDE.Graph.Rule - Development.IDE.Graph.KeyMap - Development.IDE.Graph.KeySet Development.IDE.Graph.Internal.Action - Development.IDE.Graph.Internal.Options - Development.IDE.Graph.Internal.Rules Development.IDE.Graph.Internal.Database + Development.IDE.Graph.Internal.Options Development.IDE.Graph.Internal.Paths Development.IDE.Graph.Internal.Profile + Development.IDE.Graph.Internal.Rules Development.IDE.Graph.Internal.Types + Development.IDE.Graph.KeyMap + Development.IDE.Graph.KeySet + Development.IDE.Graph.Rule Paths_hls_graph - autogen-modules: Paths_hls_graph - + autogen-modules: Paths_hls_graph hs-source-dirs: src build-depends: , aeson - , async >= 2.0 - , base >=4.12 && <5 + , async >=2.0 + , base >=4.12 && <5 , bytestring , containers , deepseq @@ -72,7 +70,7 @@ library , exceptions , extra , filepath - , focus + , focus >=1.0.3.2 , hashable , js-dgtable , js-flot @@ -80,24 +78,24 @@ library , list-t , stm , stm-containers + , text , time , transformers , unliftio , unordered-containers - , text if flag(embed-files) - cpp-options: -DFILE_EMBED - build-depends: - file-embed >= 0.0.11, - template-haskell + cpp-options: -DFILE_EMBED + build-depends: + , file-embed >=0.0.11 + , template-haskell + if flag(stm-stats) - cpp-options: -DSTM_STATS + cpp-options: -DSTM_STATS ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing - -Wno-unticked-promoted-constructors - -Wunused-packages + -Wno-unticked-promoted-constructors -Wunused-packages if flag(pedantic) ghc-options: -Werror @@ -109,10 +107,10 @@ library TypeOperators test-suite tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - main-is: Main.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs other-modules: ActionSpec DatabaseSpec @@ -120,7 +118,10 @@ test-suite tests RulesSpec Spec - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wunused-packages + ghc-options: + -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts + -Wunused-packages + build-depends: , base , containers @@ -137,4 +138,5 @@ test-suite tests , tasty-rerun , text , unordered-containers - build-tool-depends: hspec-discover:hspec-discover -any + + build-tool-depends: hspec-discover:hspec-discover diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2c3d028631..df60db344c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -34,15 +34,15 @@ source-repository head library exposed-modules: - Ide.Plugin.Error + Ide.Logger Ide.Plugin.Config Ide.Plugin.ConfigUtils + Ide.Plugin.Error Ide.Plugin.Properties Ide.Plugin.RangeMap Ide.Plugin.Resolve Ide.PluginUtils Ide.Types - Ide.Logger hs-source-dirs: src build-depends: @@ -59,10 +59,11 @@ library , filepath , ghc , hashable - , hls-graph == 2.4.0.0 + , hls-graph ==2.4.0.0 , lens , lens-aeson , lsp ^>=2.3 + , megaparsec >=9.0 , mtl , opentelemetry >=0.4 , optparse-applicative @@ -75,7 +76,6 @@ library , transformers , unliftio , unordered-containers - , megaparsec > 9 if os(windows) build-depends: Win32 @@ -85,14 +85,13 @@ library ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing - -Wno-unticked-promoted-constructors - -Wunused-packages + -Wno-unticked-promoted-constructors -Wunused-packages if flag(pedantic) ghc-options: -Werror if flag(use-fingertree) - cpp-options: -DUSE_FINGERTREE + cpp-options: -DUSE_FINGERTREE build-depends: hw-fingertree default-language: Haskell2010 @@ -107,33 +106,39 @@ test-suite tests hs-source-dirs: test main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N - other-modules: Ide.PluginUtilsTest + other-modules: + Ide.PluginUtilsTest + Ide.TypesTests + build-depends: - base + , base + , containers + , data-default , hls-plugin-api + , lens + , lsp-types , tasty , tasty-hunit - , tasty-rerun , tasty-quickcheck + , tasty-rerun , text - , lsp-types - , containers benchmark rangemap-benchmark -- Benchmark doesn't make sense if fingertree implementation -- is not used. if !flag(use-fingertree) buildable: False + type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: bench main-is: Main.hs ghc-options: -threaded -Wall build-depends: - base + , base + , criterion + , deepseq , hls-plugin-api , lsp-types - , criterion , random , random-fu - , deepseq diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 9159fc4596..ab9f30f611 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -13,7 +14,6 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -76,6 +76,7 @@ import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import qualified Data.DList as DList +import Data.Foldable (foldl') import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -560,7 +561,7 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where -- should check whether the requested kind is a *prefix* of the action kind. -- That means, for example, we will return actions with kinds `quickfix.import` and -- `quickfix.somethingElse` if the requested kind is `quickfix`. - , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed + , Just caKind <- ca ^. L.kind = any (`codeActionKindSubsumes` caKind) allowed | otherwise = False instance PluginRequestMethod Method_CodeActionResolve where @@ -569,10 +570,14 @@ instance PluginRequestMethod Method_CodeActionResolve where combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentDefinition where - combineResponses _ _ _ _ (x :| _) = x + combineResponses _ _ caps _ (x :| xs) + | Just (Just True) <- caps ^? (L.textDocument . _Just . L.definition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs + | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs instance PluginRequestMethod Method_TextDocumentTypeDefinition where - combineResponses _ _ _ _ (x :| _) = x + combineResponses _ _ caps _ (x :| xs) + | Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs + | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs instance PluginRequestMethod Method_TextDocumentDocumentHighlight where @@ -693,6 +698,45 @@ nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b) nullToMaybe' (InL x) = Just $ InL x nullToMaybe' (InR (InL x)) = Just $ InR x nullToMaybe' (InR (InR _)) = Nothing + +type Definitions = (Definition |? ([DefinitionLink] |? Null)) + +-- | Merges two definition responses (TextDocumentDefinition | TextDocumentTypeDefinition) +-- into one preserving all locations and their order (including order of the responses). +-- Upgrades Location(s) into LocationLink(s) when one of the responses is LocationLink(s). With following fields: +-- * LocationLink.originSelectionRange = Nothing +-- * LocationLink.targetUri = Location.Uri +-- * LocationLink.targetRange = Location.Range +-- * LocationLink.targetSelectionRange = Location.Range +-- Ignores Null responses. +mergeDefinitions :: Definitions -> Definitions -> Definitions +mergeDefinitions definitions1 definitions2 = case (definitions1, definitions2) of + (InR (InR Null), def2) -> def2 + (def1, InR (InR Null)) -> def1 + (InL def1, InL def2) -> InL $ mergeDefs def1 def2 + (InL def1, InR (InL links)) -> InR $ InL (defToLinks def1 ++ links) + (InR (InL links), InL def2) -> InR $ InL (links ++ defToLinks def2) + (InR (InL links1), InR (InL links2)) -> InR $ InL (links1 ++ links2) + where + defToLinks :: Definition -> [DefinitionLink] + defToLinks (Definition (InL location)) = [locationToDefinitionLink location] + defToLinks (Definition (InR locations)) = map locationToDefinitionLink locations + + locationToDefinitionLink :: Location -> DefinitionLink + locationToDefinitionLink Location{_uri, _range} = DefinitionLink LocationLink{_originSelectionRange = Nothing, _targetUri = _uri, _targetRange = _range, _targetSelectionRange = _range} + + mergeDefs :: Definition -> Definition -> Definition + mergeDefs (Definition (InL loc1)) (Definition (InL loc2)) = Definition $ InR [loc1, loc2] + mergeDefs (Definition (InR locs1)) (Definition (InL loc2)) = Definition $ InR (locs1 ++ [loc2]) + mergeDefs (Definition (InL loc1)) (Definition (InR locs2)) = Definition $ InR (loc1 : locs2) + mergeDefs (Definition (InR locs1)) (Definition (InR locs2)) = Definition $ InR (locs1 ++ locs2) + +downgradeLinks :: Definitions -> Definitions +downgradeLinks (InR (InL links)) = InL . Definition . InR . map linkToLocation $ links + where + linkToLocation :: DefinitionLink -> Location + linkToLocation (DefinitionLink LocationLink{_targetUri, _targetRange}) = Location {_uri = _targetUri, _range = _targetRange} +downgradeLinks defs = defs -- --------------------------------------------------------------------- -- Plugin Notifications -- --------------------------------------------------------------------- @@ -942,7 +986,7 @@ mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do -- as this is filtered out in `pluginEnabled` _ -> throwError $ PluginInternalError invalidRequest where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!" - parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err) + parseError value err = "Unable to decode: " <> T.pack (show value) <> ". Error: " <> T.pack (show err) wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a wrapResolveData pid uri hasData = diff --git a/hls-plugin-api/test/Ide/TypesTests.hs b/hls-plugin-api/test/Ide/TypesTests.hs new file mode 100644 index 0000000000..c5ceab7ed2 --- /dev/null +++ b/hls-plugin-api/test/Ide/TypesTests.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Ide.TypesTests + ( tests + ) where +import Control.Lens (preview, (?~), (^?)) +import Control.Monad ((>=>)) +import Data.Default (Default (def)) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.Maybe (isJust) +import qualified Data.Text as Text +import Ide.Types (Config (Config), + PluginRequestMethod (combineResponses)) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition), + SMethod (..)) +import Language.LSP.Protocol.Types (ClientCapabilities, + Definition (Definition), + DefinitionClientCapabilities (DefinitionClientCapabilities, _dynamicRegistration, _linkSupport), + DefinitionLink (DefinitionLink), + DefinitionParams (DefinitionParams, _partialResultToken, _position, _textDocument, _workDoneToken), + Location (Location), + LocationLink (LocationLink), + Null (Null), + Position (Position), + Range (Range), + TextDocumentClientCapabilities (TextDocumentClientCapabilities, _definition), + TextDocumentIdentifier (TextDocumentIdentifier), + TypeDefinitionClientCapabilities (TypeDefinitionClientCapabilities, _dynamicRegistration, _linkSupport), + TypeDefinitionParams (..), + Uri (Uri), _L, _R, + _typeDefinition, filePathToUri, + type (|?) (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@=?)) +import Test.Tasty.QuickCheck (ASCIIString (ASCIIString), + Arbitrary (arbitrary), Gen, + NonEmptyList (NonEmpty), + arbitraryBoundedEnum, cover, + listOf1, oneof, testProperty, + (===)) + +tests :: TestTree +tests = testGroup "PluginTypes" + [ combineResponsesTests ] + +combineResponsesTests :: TestTree +combineResponsesTests = testGroup "combineResponses" + [ combineResponsesTextDocumentDefinitionTests + , combineResponsesTextDocumentTypeDefinitionTests + ] + +combineResponsesTextDocumentDefinitionTests :: TestTree +combineResponsesTextDocumentDefinitionTests = testGroup "TextDocumentDefinition" $ + defAndTypeDefSharedTests SMethod_TextDocumentDefinition definitionParams + +combineResponsesTextDocumentTypeDefinitionTests :: TestTree +combineResponsesTextDocumentTypeDefinitionTests = testGroup "TextDocumentTypeDefinition" $ + defAndTypeDefSharedTests SMethod_TextDocumentTypeDefinition typeDefinitionParams + +defAndTypeDefSharedTests message params = + [ testCase "merges all single location responses into one response with all locations (without upgrading to links)" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InL . Definition . InL . Location testFileUri $ range1) :| + [ InL . Definition . InL . Location testFileUri $ range2 + , InL . Definition . InL . Location testFileUri $ range3 + ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InL . Definition . InR $ + [ Location testFileUri range1 + , Location testFileUri range2 + , Location testFileUri range3 + ] + expectedResult @=? result + + , testCase "merges all location link responses into one with all links (with link support)" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range1 range1]) :| + [ InR . InL $ + [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2 + , DefinitionLink $ LocationLink Nothing testFileUri range3 range3 + ] + ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InR . InL $ + [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1 + , DefinitionLink $ LocationLink Nothing testFileUri range2 range2 + , DefinitionLink $ LocationLink Nothing testFileUri range3 range3 + ] + expectedResult @=? result + + , testCase "merges location responses with link responses into link responses (with link support)" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InL . Definition . InL . Location testFileUri $ range1) :| + [ InR . InL $ [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2 ] + , InL . Definition . InR $ [Location testFileUri range3] + ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InR . InL $ + [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1 + , DefinitionLink $ LocationLink Nothing testFileUri range2 range2 + , DefinitionLink $ LocationLink Nothing testFileUri range3 range3 + ] + expectedResult @=? result + + , testCase "preserves link-specific data when merging link and location responses (with link support)" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InL . Definition . InL . Location testFileUri $ range1) :| + [ InR . InL $ [ DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3 ] ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InR . InL $ + [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1 + , DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3 + ] + expectedResult @=? result + + , testCase "ignores Null responses when other responses are available" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InL . Definition . InL . Location testFileUri $ range1) :| + [ InR . InR $ Null + , InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range3 range3] + ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InR . InL $ + [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1 + , DefinitionLink $ LocationLink Nothing testFileUri range3 range3 + ] + expectedResult @=? result + + , testCase "returns Null when all responses are Null" $ do + let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null)) + pluginResponses = + (InR . InR $ Null) :| + [ InR . InR $ Null + , InR . InR $ Null + ] + + result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses + + expectedResult :: Definition |? ([DefinitionLink] |? Null) + expectedResult = InR . InR $ Null + expectedResult @=? result + + , testProperty "downgrades all locationLinks to locations when missing link support in capabilities" $ \(MkGeneratedNonEmpty responses) -> do + let pluginResponses = fmap (\(MkGeneratedDefinition definition) -> definition) responses + + result = combineResponses message def def params pluginResponses + + cover 70 (any (isJust . (>>= (^? _L)) . (^? _R)) pluginResponses) "Has at least one response with links" $ + cover 10 (any (isJust . (^? _L)) pluginResponses) "Has at least one response with locations" $ + cover 10 (any (isJust . (>>= (^? _R)) . (^? _R)) pluginResponses) "Has at least one response with Null" $ + (isJust (result ^? _L) || isJust (result ^? _R >>= (^? _R))) === True + ] + +(range1, range2, range3) = (Range (Position 3 0) $ Position 3 5, Range (Position 5 7) $ Position 5 13, Range (Position 24 30) $ Position 24 40) + +supportsLinkInAllDefinitionCaps :: ClientCapabilities +supportsLinkInAllDefinitionCaps = def & L.textDocument ?~ textDocumentCaps + where + textDocumentCaps :: TextDocumentClientCapabilities + textDocumentCaps = def + { _definition = Just DefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing } + , _typeDefinition = Just TypeDefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing } + } + +definitionParams :: DefinitionParams +definitionParams = DefinitionParams + { _textDocument = TextDocumentIdentifier testFileUri + , _position = Position 5 4 + , _workDoneToken = Nothing + , _partialResultToken = Nothing + } + +typeDefinitionParams :: TypeDefinitionParams +typeDefinitionParams = TypeDefinitionParams + { _textDocument = TextDocumentIdentifier testFileUri + , _position = Position 5 4 + , _workDoneToken = Nothing + , _partialResultToken = Nothing + } + +testFileUri :: Uri +testFileUri = filePathToUri "file://tester/Test.hs" + +newtype GeneratedDefinition = MkGeneratedDefinition (Definition |? ([DefinitionLink] |? Null)) deriving newtype (Show) + +instance Arbitrary GeneratedDefinition where + arbitrary = MkGeneratedDefinition <$> oneof + [ InL . Definition . InL <$> generateLocation + , InL . Definition . InR <$> listOf1 generateLocation + , InR . InL . map DefinitionLink <$> listOf1 generateLocationLink + , pure . InR . InR $ Null + ] + where + generateLocation :: Gen Location + generateLocation = do + (LocationLink _ uri range _) <- generateLocationLink + pure $ Location uri range + + generateLocationLink :: Gen LocationLink + generateLocationLink = LocationLink <$> generateMaybe generateRange <*> generateUri <*> generateRange <*> generateRange + + generateMaybe :: Gen a -> Gen (Maybe a) + generateMaybe gen = oneof [Just <$> gen, pure Nothing] + + generateUri :: Gen Uri + generateUri = do + (ASCIIString str) <- arbitrary + pure . Uri . Text.pack $ str + + generateRange :: Gen Range + generateRange = Range <$> generatePosition <*> generatePosition + + generatePosition :: Gen Position + generatePosition = Position <$> arbitraryBoundedEnum <*> arbitraryBoundedEnum + +newtype GeneratedNonEmpty a = MkGeneratedNonEmpty (NonEmpty a) deriving newtype (Show) + +instance Arbitrary a => Arbitrary (GeneratedNonEmpty a) where + arbitrary = MkGeneratedNonEmpty <$> ((:|) <$> arbitrary <*> arbitrary) diff --git a/hls-plugin-api/test/Main.hs b/hls-plugin-api/test/Main.hs index fc58853b4b..006052631d 100644 --- a/hls-plugin-api/test/Main.hs +++ b/hls-plugin-api/test/Main.hs @@ -1,6 +1,7 @@ module Main where import qualified Ide.PluginUtilsTest as PluginUtilsTest +import qualified Ide.TypesTests as PluginTypesTests import Test.Tasty import Test.Tasty.Ingredients.Rerun @@ -10,4 +11,5 @@ main = defaultMainWithRerun tests tests :: TestTree tests = testGroup "Main" [ PluginUtilsTest.tests + , PluginTypesTests.tests ]