mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-08-16 20:10:30 +03:00
A plugin for GADT syntax converter (#2899)
* initial hls-gadt-plugin * Correct condition * Render context correctly * Fix typo * Support from ghc-8.6 to ghc-9.0 * ghc8.6 compat * Try to fix test for ghc-8.6 * Pretty name * Add GADTs pragma automatically * Enrich Readme * Clean up * Update hls docs * Update CODEOWNERS * Fix typo * Rename withTempDir with withCanonicalTempDir * Add @michaelpj's suggestions * Pass PluginId through descriptor * Explicit forall
This commit is contained in:
parent
1a0d4a7621
commit
faa88f685e
4
.github/workflows/test.yml
vendored
4
.github/workflows/test.yml
vendored
@ -246,6 +246,10 @@ jobs:
|
||||
name: Test hls-change-type-signature test suite
|
||||
run: cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS"
|
||||
|
||||
- if: matrix.test
|
||||
name: Test hls-gadt-plugin test suit
|
||||
run: cabal test hls-gadt-plugin --test-options="$TEST_OPTS" || cabal test hls-gadt-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-gadt-plugin --test-options="$TEST_OPTS"
|
||||
|
||||
test_post_job:
|
||||
if: always()
|
||||
runs-on: ubuntu-latest
|
||||
|
@ -15,6 +15,7 @@
|
||||
/plugins/hls-explicit-imports-plugin @pepeiborra
|
||||
/plugins/hls-floskell-plugin @Ailrun
|
||||
/plugins/hls-fourmolu-plugin @georgefst
|
||||
/plugins/hls-gadt-plugin @July541
|
||||
/plugins/hls-haddock-comments-plugin @berberman
|
||||
/plugins/hls-hlint-plugin @jneira @eddiemundo
|
||||
/plugins/hls-module-name-plugin
|
||||
|
@ -28,6 +28,7 @@ packages:
|
||||
./plugins/hls-qualify-imported-names-plugin
|
||||
./plugins/hls-selection-range-plugin
|
||||
./plugins/hls-change-type-signature-plugin
|
||||
./plugins/hls-gadt-plugin
|
||||
|
||||
-- Standard location for temporary packages needed for particular environments
|
||||
-- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script
|
||||
|
@ -256,7 +256,19 @@ Known Limitations:
|
||||
|
||||
![Change Type Signature Demo](../plugins/hls-change-type-signature-plugin/change2.gif)
|
||||
|
||||
[Link to Docs](../plugins/hls-change-type-signature/README.md)
|
||||
![Link to Docs](../plugins/hls-change-type-signature-plugin/README.md)
|
||||
|
||||
### Convert to GADT syntax
|
||||
|
||||
Provided by: `hls-gadt-plugin`
|
||||
|
||||
Code action kind: `refactor.rewrite`
|
||||
|
||||
Convert a datatype to GADT syntax.
|
||||
|
||||
![GADT Demo](../plugins/hls-gadt-plugin/gadt.gif)
|
||||
|
||||
![Link to Docs](../plugins/hls-gadt-plugin/README.md)
|
||||
|
||||
## Code lenses
|
||||
|
||||
|
@ -55,6 +55,7 @@ Sometimes a plugin will be supported in the prebuilt binaries but not in a HLS b
|
||||
| `hls-stylish-haskell-plugin` | |
|
||||
| `hls-tactics-plugin` | 9.2 |
|
||||
| `hls-selection-range-plugin` | |
|
||||
| `hls-gadt-plugin` | |
|
||||
|
||||
### Using deprecated GHC versions
|
||||
|
||||
|
@ -82,6 +82,10 @@ import Ide.Plugin.SelectionRange as SelectionRange
|
||||
#if changeTypeSignature
|
||||
import Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature
|
||||
#endif
|
||||
|
||||
#if gadt
|
||||
import Ide.Plugin.GADT as GADT
|
||||
#endif
|
||||
-- formatters
|
||||
|
||||
#if floskell
|
||||
@ -190,6 +194,9 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
|
||||
#endif
|
||||
#if changeTypeSignature
|
||||
ChangeTypeSignature.descriptor "changeTypeSignature" :
|
||||
#endif
|
||||
#if gadt
|
||||
GADT.descriptor "gadt" :
|
||||
#endif
|
||||
-- The ghcide descriptors should come last so that the notification handlers
|
||||
-- (which restart the Shake build) run after everything else
|
||||
|
@ -186,6 +186,11 @@ flag changeTypeSignature
|
||||
default: True
|
||||
manual: True
|
||||
|
||||
flag gadt
|
||||
description: Enable gadt plugin
|
||||
default: True
|
||||
manual: True
|
||||
|
||||
-- formatters
|
||||
|
||||
flag floskell
|
||||
@ -308,6 +313,11 @@ common changeTypeSignature
|
||||
build-depends: hls-change-type-signature-plugin ^>= 1.0
|
||||
cpp-options: -DchangeTypeSignature
|
||||
|
||||
common gadt
|
||||
if flag(gadt)
|
||||
build-depends: hls-gadt-plugin ^>= 1.0
|
||||
cpp-options: -Dgadt
|
||||
|
||||
-- formatters
|
||||
|
||||
common floskell
|
||||
@ -359,6 +369,7 @@ executable haskell-language-server
|
||||
, alternateNumberFormat
|
||||
, qualifyImportedNames
|
||||
, selectionRange
|
||||
, gadt
|
||||
, floskell
|
||||
, fourmolu
|
||||
, ormolu
|
||||
|
@ -56,7 +56,6 @@ import Language.LSP.Types hiding
|
||||
SemanticTokensEdit (_start))
|
||||
import qualified Language.LSP.Types as J
|
||||
import Language.LSP.Types.Capabilities
|
||||
import Language.LSP.Types.Lens (uri)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
@ -40,6 +40,7 @@ module Test.Hls.Util
|
||||
, waitForDiagnosticsFromSourceWithTimeout
|
||||
, withCurrentDirectoryInTmp
|
||||
, withCurrentDirectoryInTmp'
|
||||
, withCanonicalTempDir
|
||||
)
|
||||
where
|
||||
|
||||
@ -54,7 +55,7 @@ import Data.Default
|
||||
import Data.List.Extra (find)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE (GhcVersion(..), ghcVersion)
|
||||
import Development.IDE (GhcVersion (..), ghcVersion)
|
||||
import qualified Language.LSP.Test as Test
|
||||
import Language.LSP.Types hiding (Reason (..))
|
||||
import qualified Language.LSP.Types.Capabilities as C
|
||||
@ -62,8 +63,9 @@ import qualified Language.LSP.Types.Lens as L
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO.Temp
|
||||
import System.Info.Extra (isMac, isWindows)
|
||||
import qualified System.IO.Extra
|
||||
import System.IO.Temp
|
||||
import System.Time.Extra (Seconds, sleep)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.ExpectedFailure (expectFailBecause,
|
||||
@ -253,7 +255,7 @@ onMatch :: [a] -> (a -> Bool) -> String -> IO a
|
||||
onMatch as predicate err = maybe (fail err) return (find predicate as)
|
||||
|
||||
noMatch :: [a] -> (a -> Bool) -> String -> IO ()
|
||||
noMatch [] _ _ = pure ()
|
||||
noMatch [] _ _ = pure ()
|
||||
noMatch as predicate err = bool (pure ()) (fail err) (any predicate as)
|
||||
|
||||
inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic
|
||||
@ -384,3 +386,10 @@ getCompletionByLabel desiredLabel compls =
|
||||
Nothing -> liftIO . assertFailure $
|
||||
"Completion with label " <> show desiredLabel
|
||||
<> " not found in " <> show (fmap (^. L.label) compls)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- Run with a canonicalized temp dir
|
||||
withCanonicalTempDir :: (FilePath -> IO a) -> IO a
|
||||
withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
|
||||
dir' <- canonicalizePath dir
|
||||
f dir'
|
||||
|
@ -19,6 +19,7 @@ import System.Directory.Extra
|
||||
import System.FilePath
|
||||
import qualified System.IO.Extra
|
||||
import Test.Hls
|
||||
import Test.Hls.Util (withCanonicalTempDir)
|
||||
|
||||
plugin :: PluginDescriptor IdeState
|
||||
plugin = descriptor "callHierarchy"
|
||||
@ -319,7 +320,7 @@ outgoingCallsTests =
|
||||
testGroup "Outgoing Calls"
|
||||
[ testGroup "single file"
|
||||
[
|
||||
testCase "xdata unavailable" $ withTempDir $ \dir ->
|
||||
testCase "xdata unavailable" $ withCanonicalTempDir $ \dir ->
|
||||
runSessionWithServer plugin dir $ do
|
||||
doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
|
||||
waitForKickDone
|
||||
@ -423,7 +424,7 @@ deriving instance Ord CallHierarchyIncomingCall
|
||||
deriving instance Ord CallHierarchyOutgoingCall
|
||||
|
||||
incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion
|
||||
incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir ->
|
||||
incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->
|
||||
runSessionWithServer plugin dir $ do
|
||||
doc <- createDoc "A.hs" "haskell" contents
|
||||
waitForKickDone
|
||||
@ -465,7 +466,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp =
|
||||
closeDoc doc
|
||||
|
||||
outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion
|
||||
outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \dir ->
|
||||
outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir ->
|
||||
runSessionWithServer plugin dir $ do
|
||||
doc <- createDoc "A.hs" "haskell" contents
|
||||
waitForKickDone
|
||||
@ -505,7 +506,7 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
|
||||
closeDoc doc
|
||||
|
||||
oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion
|
||||
oneCaseWithCreate contents queryX queryY expected = withTempDir $ \dir ->
|
||||
oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir ->
|
||||
runSessionWithServer plugin dir $ do
|
||||
doc <- createDoc "A.hs" "haskell" contents
|
||||
waitForKickDone
|
||||
@ -544,8 +545,3 @@ mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing
|
||||
|
||||
mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams
|
||||
mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing
|
||||
|
||||
withTempDir :: (FilePath -> IO a) -> IO a
|
||||
withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
|
||||
dir' <- canonicalizePath dir
|
||||
f dir'
|
||||
|
201
plugins/hls-gadt-plugin/LICENSE
Normal file
201
plugins/hls-gadt-plugin/LICENSE
Normal file
@ -0,0 +1,201 @@
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright [yyyy] [name of copyright owner]
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
22
plugins/hls-gadt-plugin/README.md
Normal file
22
plugins/hls-gadt-plugin/README.md
Normal file
@ -0,0 +1,22 @@
|
||||
# GADT Converter Plugin
|
||||
|
||||
The hls-gadt-plugin provides a code action that converts a datatype to GADT syntax.
|
||||
|
||||
## Demo
|
||||
|
||||
![GADT](gadt.gif)
|
||||
|
||||
## Design
|
||||
The plugin works in the following steps:
|
||||
1. Get data declarations and enabled pragmas from parsed source.
|
||||
2. Response a code action with a command to convert to GADT syntax if given position is a H98 data declaration.
|
||||
3. Convert every part of H98 declaration to corresponding GADT's.
|
||||
4. Print converted declaration. (See `prettyGADTDecl` source code for details)
|
||||
5. Send edit request to LSP, the edit includes replacing origin data declaration to GADT and inserting a `GADTs` pragma if necessary.
|
||||
|
||||
## Known limitations
|
||||
- Currently all comments missed while converting to GADT syntax.
|
||||
|
||||
## Change log
|
||||
### 1.0.0.0
|
||||
- Release
|
BIN
plugins/hls-gadt-plugin/gadt.gif
Normal file
BIN
plugins/hls-gadt-plugin/gadt.gif
Normal file
Binary file not shown.
After Width: | Height: | Size: 692 KiB |
61
plugins/hls-gadt-plugin/hls-gadt-plugin.cabal
Normal file
61
plugins/hls-gadt-plugin/hls-gadt-plugin.cabal
Normal file
@ -0,0 +1,61 @@
|
||||
cabal-version: 2.4
|
||||
name: hls-gadt-plugin
|
||||
version: 1.0.0.0
|
||||
synopsis: Convert to GADT syntax plugin
|
||||
description:
|
||||
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/plugins/hls-gadt-plugin#readme>
|
||||
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Lei Zhu
|
||||
maintainer: julytreee@gmail.com
|
||||
category: Development
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
LICENSE
|
||||
test/testdata/*.hs
|
||||
|
||||
library
|
||||
exposed-modules: Ide.Plugin.GADT
|
||||
other-modules: Ide.Plugin.GHC
|
||||
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
, aeson
|
||||
, base >=4.12 && <5
|
||||
, containers
|
||||
, extra
|
||||
, ghc
|
||||
, ghcide ^>= 1.7
|
||||
, ghc-boot-th
|
||||
, ghc-exactprint
|
||||
, hls-plugin-api ^>= 1.4
|
||||
, lens
|
||||
, lsp >=1.2.0.1
|
||||
, mtl
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers
|
||||
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wno-name-shadowing
|
||||
-Wno-unticked-promoted-constructors
|
||||
default-language: Haskell2010
|
||||
default-extensions: DataKinds
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Main.hs
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
, base
|
||||
, filepath
|
||||
, hls-gadt-plugin
|
||||
, hls-test-utils ^>=1.3
|
||||
, lens
|
||||
, lsp
|
||||
, lsp-test
|
||||
, text
|
131
plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs
Normal file
131
plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs
Normal file
@ -0,0 +1,131 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Ide.Plugin.GADT (descriptor) where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson (FromJSON, ToJSON,
|
||||
Value (Null), toJSON)
|
||||
import Data.Either.Extra (maybeToEither)
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE
|
||||
import Development.IDE.GHC.Compat
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Development.IDE.GHC.Compat.Util (toList)
|
||||
import Development.IDE.Spans.Pragmas (NextPragmaInfo,
|
||||
getNextPragmaInfo,
|
||||
insertNewPragma)
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.LanguageExtensions.Type (Extension (GADTSyntax, GADTs))
|
||||
import Ide.Plugin.GHC
|
||||
import Ide.PluginUtils
|
||||
import Ide.Types
|
||||
import Language.LSP.Server (sendRequest)
|
||||
import Language.LSP.Types
|
||||
import qualified Language.LSP.Types.Lens as L
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ Ide.Types.pluginHandlers =
|
||||
mkPluginHandler STextDocumentCodeAction codeActionHandler
|
||||
, pluginCommands =
|
||||
[PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)]
|
||||
}
|
||||
|
||||
-- | Parameter used in the command
|
||||
data ToGADTParams = ToGADTParams
|
||||
{ uri :: Uri
|
||||
, range :: Range
|
||||
} deriving (Generic, ToJSON, FromJSON)
|
||||
|
||||
toGADTSyntaxCommandId :: CommandId
|
||||
toGADTSyntaxCommandId = "GADT.toGADT"
|
||||
|
||||
-- | A command replaces H98 data decl with GADT decl in place
|
||||
toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams
|
||||
toGADTCommand plId state ToGADTParams{..} = response $ do
|
||||
nfp <- getNormalizedFilePath plId uri
|
||||
(decls, exts) <- getInRangeH98DeclsAndExts state range nfp
|
||||
(L ann decl) <- case decls of
|
||||
[d] -> pure d
|
||||
_ -> throwE $ "Expected 1 declaration, but got " <> show (Prelude.length decls)
|
||||
deps <- liftIO $ runAction "GADT.GhcSessionDeps" state $ use GhcSessionDeps nfp
|
||||
(hsc_dflags . hscEnv -> df) <- liftEither
|
||||
$ maybeToEither "Get GhcSessionDeps failed" deps
|
||||
txt <- liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl
|
||||
range <- liftEither
|
||||
$ maybeToEither "Unable to get data decl range"
|
||||
$ srcSpanToRange $ locA ann
|
||||
pragma <- getNextPragma state nfp
|
||||
let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]]
|
||||
|
||||
_ <- lift $ sendRequest
|
||||
SWorkspaceApplyEdit
|
||||
(ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit)))
|
||||
(\_ -> pure ())
|
||||
|
||||
pure Null
|
||||
where
|
||||
workSpaceEdit nfp edits = WorkspaceEdit
|
||||
(pure $ HashMap.fromList
|
||||
[(filePathToUri $ fromNormalizedFilePath nfp,
|
||||
List edits)])
|
||||
Nothing Nothing
|
||||
|
||||
codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction
|
||||
codeActionHandler state plId (CodeActionParams _ _ doc range _) = response $ do
|
||||
nfp <- getNormalizedFilePath plId (doc ^. L.uri)
|
||||
(inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp
|
||||
let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls
|
||||
pure $ List actions
|
||||
where
|
||||
mkAction :: T.Text -> Command |? CodeAction
|
||||
mkAction name = InR CodeAction{..}
|
||||
where
|
||||
_title = "Convert \"" <> name <> "\" to GADT syntax"
|
||||
_kind = Just CodeActionRefactorRewrite
|
||||
_diagnostics = Nothing
|
||||
_isPreferred = Nothing
|
||||
_disabled = Nothing
|
||||
_edit = Nothing
|
||||
_command = Just
|
||||
$ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam])
|
||||
_xdata = Nothing
|
||||
|
||||
mkParam = ToGADTParams (doc ^. L.uri) range
|
||||
|
||||
-- | Get all H98 decls in the given range, and enabled extensions
|
||||
getInRangeH98DeclsAndExts :: (MonadIO m) =>
|
||||
IdeState
|
||||
-> Range
|
||||
-> NormalizedFilePath
|
||||
-> ExceptT String m ([LTyClDecl GP], [Extension])
|
||||
getInRangeH98DeclsAndExts state range nfp = do
|
||||
pm <- handleMaybeM "Unable to get ParsedModuleWithComments"
|
||||
$ liftIO
|
||||
$ runAction "GADT.GetParsedModuleWithComments" state
|
||||
$ use GetParsedModuleWithComments nfp
|
||||
let (L _ hsDecls) = hsmodDecls <$> pm_parsed_source pm
|
||||
decls = filter isH98DataDecl
|
||||
$ mapMaybe getDataDecl
|
||||
$ filter (inRange range) hsDecls
|
||||
exts = (toList . extensionFlags . ms_hspp_opts . pm_mod_summary) pm
|
||||
pure (decls, exts)
|
||||
|
||||
-- Copy from hls-alternate-number-format-plugin
|
||||
getNextPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
|
||||
getNextPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do
|
||||
ghcSession <- liftIO $ runAction "GADT.GhcSession" state $ useWithStale GhcSession nfp
|
||||
(_, fileContents) <- liftIO $ runAction "GADT.GetFileContents" state $ getFileContents nfp
|
||||
case ghcSession of
|
||||
Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents
|
||||
Nothing -> pure Nothing
|
304
plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs
Normal file
304
plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs
Normal file
@ -0,0 +1,304 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
|
||||
module Ide.Plugin.GHC where
|
||||
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List.Extra (stripInfix)
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE
|
||||
import Development.IDE.GHC.Compat
|
||||
import Ide.PluginUtils (subRange)
|
||||
import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
import GHC.Parser.Annotation (AddEpAnn (..),
|
||||
Anchor (Anchor),
|
||||
AnchorOperation (MovedAnchor),
|
||||
DeltaPos (..),
|
||||
EpAnn (..),
|
||||
EpAnnComments (EpaComments),
|
||||
EpaLocation (EpaDelta),
|
||||
SrcSpanAnn' (SrcSpanAnn),
|
||||
spanAsAnchor)
|
||||
import Language.Haskell.GHC.ExactPrint (showAst)
|
||||
#else
|
||||
import qualified Data.Map.Lazy as Map
|
||||
import Language.Haskell.GHC.ExactPrint.Types (AnnConName (CN),
|
||||
AnnKey (AnnKey),
|
||||
Annotation (..),
|
||||
DeltaPos (DP),
|
||||
KeywordId (G),
|
||||
deltaColumn)
|
||||
#endif
|
||||
|
||||
type GP = GhcPass Parsed
|
||||
|
||||
-- | Check if a given range is in the range of located item
|
||||
inRange :: HasSrcSpan a => Range -> a -> Bool
|
||||
inRange range s = maybe False (subRange range) (srcSpanToRange (getLoc s))
|
||||
|
||||
-- | Get data decl and its location
|
||||
getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP)
|
||||
getDataDecl (L l (TyClD _ d@DataDecl{})) = Just (L l d)
|
||||
getDataDecl _ = Nothing
|
||||
|
||||
isConDeclH98 :: ConDecl GP -> Bool
|
||||
isConDeclH98 ConDeclH98{} = True
|
||||
isConDeclH98 _ = False
|
||||
|
||||
isH98DataDecl :: LTyClDecl GP -> Bool
|
||||
isH98DataDecl (L _ decl@DataDecl{}) =
|
||||
any (isConDeclH98 . (\(L _ r) -> r)) (dd_cons $ tcdDataDefn decl)
|
||||
isH98DataDecl _ = False
|
||||
|
||||
-- | Convert H98 data type definition to GADT's
|
||||
h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP
|
||||
h98ToGADTDecl = \case
|
||||
DataDecl{..} -> DataDecl
|
||||
{ tcdDataDefn = updateDefn tcdLName tcdTyVars tcdDataDefn
|
||||
, ..
|
||||
}
|
||||
x -> x
|
||||
where
|
||||
updateDefn dataName tyVars = \case
|
||||
HsDataDefn{..} -> HsDataDefn
|
||||
{ dd_cons =
|
||||
mapX (h98ToGADTConDecl dataName tyVars (wrapCtxt dd_ctxt)) <$> dd_cons
|
||||
, dd_ctxt = emptyCtxt -- Context can't appear at the data name in GADT
|
||||
, ..
|
||||
}
|
||||
x -> x
|
||||
|
||||
-- | Convert H98 data constuctor to GADT data constructor
|
||||
h98ToGADTConDecl ::
|
||||
LIdP GP -- ^Type constuctor name,
|
||||
-- used for constucting final result type in GADT
|
||||
-> LHsQTyVars GP
|
||||
-- ^Type variable names
|
||||
-- used for constucting final result type in GADT
|
||||
-> Maybe (LHsContext GP)
|
||||
-- ^Data type context
|
||||
-> ConDecl GP
|
||||
-> ConDecl GP
|
||||
h98ToGADTConDecl dataName tyVars ctxt = \case
|
||||
ConDeclH98{..} ->
|
||||
ConDeclGADT
|
||||
con_ext
|
||||
[con_name]
|
||||
#if !MIN_VERSION_ghc(9,2,1)
|
||||
con_forall
|
||||
#endif
|
||||
-- Ignore all existential type variable since GADT not needed
|
||||
implicitTyVars
|
||||
(mergeContext ctxt con_mb_cxt)
|
||||
(renderDetails con_args)
|
||||
renderResultTy
|
||||
con_doc
|
||||
x -> x
|
||||
where
|
||||
-- Parameters in the data constructor
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP
|
||||
renderDetails (PrefixCon _ args) = PrefixConGADT args
|
||||
renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2]
|
||||
renderDetails (RecCon recs) = RecConGADT recs
|
||||
#else
|
||||
renderDetails (PrefixCon args) = PrefixCon args
|
||||
renderDetails (InfixCon arg1 arg2) = PrefixCon [arg1, arg2]
|
||||
renderDetails (RecCon recs) = RecCon recs
|
||||
#endif
|
||||
|
||||
-- | Construct GADT result type
|
||||
renderResultTy :: LHsType GP
|
||||
renderResultTy = case tyVars of
|
||||
-- Without type variable
|
||||
HsQTvs _ [] -> wrappedDataName
|
||||
-- With type variable
|
||||
HsQTvs _ vars -> foldl go wrappedDataName vars
|
||||
_ -> wrappedDataName
|
||||
where
|
||||
wrappedDataName = wrap (HsTyVar noUsed NotPromoted dataName)
|
||||
|
||||
-- Bundle data name with type vars by `HsAppTy`
|
||||
go acc (L _(UserTyVar' var)) =
|
||||
wrap
|
||||
(HsAppTy noExtField acc
|
||||
(wrap (HsTyVar noUsed NotPromoted var)))
|
||||
go acc _ = acc
|
||||
|
||||
-- Merge data type context and constructor type context
|
||||
mergeContext :: Maybe (LHsContext GP) -> Maybe (LHsContext GP) -> Maybe (LHsContext GP)
|
||||
mergeContext ctxt1 ctxt2 =
|
||||
(wrap . map wrap) . map unParTy
|
||||
<$> (getContextType ctxt1 <> getContextType ctxt2)
|
||||
where
|
||||
getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP]
|
||||
getContextType ctxt = map unWrap . unWrap <$> ctxt
|
||||
|
||||
-- Unparen the outmost, it only occurs at the outmost
|
||||
-- for a valid type.
|
||||
--
|
||||
-- Note for context paren rule:
|
||||
--
|
||||
-- If only one element, it __can__ have a paren type.
|
||||
-- If not, there can't have a parent type.
|
||||
unParTy :: HsType GP -> HsType GP
|
||||
unParTy (HsParTy _ ty) = unWrap ty
|
||||
unParTy x = x
|
||||
{- |
|
||||
We use `printOutputable` to print H98 data decl as GADT syntax,
|
||||
this print is not perfect, it will:
|
||||
|
||||
1. Make data name and the `where` key word in different lines.
|
||||
2. Make the whole data decl prints in one line if there is only one data constructor.
|
||||
3. The ident size of every data constructor depends on its origin
|
||||
format, and may have different ident size between constructors.
|
||||
|
||||
Hence, we first use `printOutputable` to get an initial GADT syntax,
|
||||
then use `ghc-exactprint` to parse the initial result, and finally
|
||||
adjust the details that mentioned above.
|
||||
|
||||
The adjustment includes:
|
||||
|
||||
1. Make the `where` key word at the same line of data name.
|
||||
2. Remove the extra blank line caused by adjustment of `where`.
|
||||
3. Make every data constructor start with a new line and 2 spaces
|
||||
-}
|
||||
prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
prettyGADTDecl df decl =
|
||||
let old = printOutputable decl
|
||||
hsDecl = parseDecl df "unused" (T.unpack old)
|
||||
tycld = adjustTyClD hsDecl
|
||||
in removeExtraEmptyLine . exactPrint <$> tycld
|
||||
where
|
||||
adjustTyClD = \case
|
||||
Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld
|
||||
Right x -> Left $ "Expect TyClD but got " <> showAst x
|
||||
Left err -> Left $ show err
|
||||
|
||||
adjustDataDecl DataDecl{..} = DataDecl
|
||||
{ tcdDExt = adjustWhere tcdDExt
|
||||
, tcdDataDefn = tcdDataDefn
|
||||
{ dd_cons = map adjustCon (dd_cons tcdDataDefn)
|
||||
}
|
||||
, ..
|
||||
}
|
||||
adjustDataDecl x = x
|
||||
|
||||
-- Make every data constructor start with a new line and 2 spaces
|
||||
adjustCon :: LConDecl GP -> LConDecl GP
|
||||
adjustCon (L (SrcSpanAnn _ loc) r) =
|
||||
L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r
|
||||
where
|
||||
go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2))
|
||||
|
||||
-- Adjust where annotation to the same line of the type constuctor
|
||||
adjustWhere tcdDExt = tcdDExt <&> map
|
||||
(\(AddEpAnn ann l) ->
|
||||
if ann == AnnWhere
|
||||
then AddEpAnn AnnWhere (EpaDelta (SameLine 1) [])
|
||||
else AddEpAnn ann l
|
||||
)
|
||||
|
||||
-- Remove the first extra line if exist
|
||||
removeExtraEmptyLine s = case stripInfix "\n\n" s of
|
||||
Just (x, xs) -> x <> "\n" <> xs
|
||||
Nothing -> s
|
||||
#else
|
||||
prettyGADTDecl df decl =
|
||||
let old = printOutputable decl
|
||||
hsDecl = parseDecl df "unused" (T.unpack old)
|
||||
tycld = adjustTyClD hsDecl
|
||||
in removeExtraEmptyLine . uncurry (flip exactPrint) <$> tycld
|
||||
where
|
||||
adjustTyClD = \case
|
||||
Right (anns, t@(L _ (TyClD _ _))) -> Right (adjustDataDeclAnns anns, t)
|
||||
Right _ -> Left "Expect TyClD"
|
||||
Left err -> Left $ show err
|
||||
|
||||
adjustDataDeclAnns = Map.mapWithKey go
|
||||
where
|
||||
isDataDeclAnn (AnnKey _ (CN name)) = name == "DataDecl"
|
||||
isConDeclGADTAnn (AnnKey _ (CN name)) = name == "ConDeclGADT"
|
||||
|
||||
go key ann
|
||||
| isDataDeclAnn key = adjustWhere ann
|
||||
| isConDeclGADTAnn key = adjustCon ann
|
||||
| otherwise = ann
|
||||
|
||||
-- Adjust where annotation to the same line of the type constuctor
|
||||
adjustWhere Ann{..} = Ann
|
||||
{ annsDP = annsDP <&>
|
||||
(\(keyword, dp) ->
|
||||
if keyword == G AnnWhere
|
||||
then (keyword, DP (0, 1))
|
||||
else (keyword, dp))
|
||||
, ..
|
||||
}
|
||||
|
||||
-- Make every data constructor start with a new line and 2 spaces
|
||||
--
|
||||
-- Here we can't force every GADT constuctor has (1, 2)
|
||||
-- delta. For the first constructor with (1, 2), it prints
|
||||
-- a new line with 2 spaces, but for other constructors
|
||||
-- with (1, 2), it will print a new line with 4 spaces.
|
||||
--
|
||||
-- The original ann parsed with `praseDecl` shows the first
|
||||
-- constructor has (1, 4) delta, but others have (1, 0).
|
||||
-- Hence, the following code only deal with the first
|
||||
-- constructor.
|
||||
adjustCon Ann{..} = let c = deltaColumn annEntryDelta
|
||||
in Ann
|
||||
{ annEntryDelta = DP $ (1,) $ if c > 0 then 2 else 0
|
||||
, ..
|
||||
}
|
||||
|
||||
-- Remove the first extra line if exist
|
||||
removeExtraEmptyLine s = case stripInfix "\n\n" s of
|
||||
Just (x, xs) -> x <> "\n" <> xs
|
||||
Nothing -> s
|
||||
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
wrap :: forall a. WrapXRec GP a => a -> XRec GP a
|
||||
wrap = wrapXRec @GP
|
||||
wrapCtxt = id
|
||||
emptyCtxt = Nothing
|
||||
unWrap = unXRec @GP
|
||||
mapX = mapXRec @GP
|
||||
noUsed = EpAnnNotUsed
|
||||
#else
|
||||
wrapCtxt = Just
|
||||
wrap = L noSrcSpan
|
||||
emptyCtxt = wrap []
|
||||
unWrap (L _ r) = r
|
||||
mapX = fmap
|
||||
noUsed = noExtField
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,1)
|
||||
pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass
|
||||
pattern UserTyVar' s <- UserTyVar _ _ s
|
||||
#else
|
||||
pattern UserTyVar' :: LIdP pass -> HsTyVarBndr pass
|
||||
pattern UserTyVar' s <- UserTyVar _ s
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,1)
|
||||
implicitTyVars = (wrapXRec @GP mkHsOuterImplicit)
|
||||
#elif MIN_VERSION_ghc(9,0,1)
|
||||
implicitTyVars = []
|
||||
#else
|
||||
implicitTyVars = HsQTvs noExtField []
|
||||
#endif
|
81
plugins/hls-gadt-plugin/test/Main.hs
Normal file
81
plugins/hls-gadt-plugin/test/Main.hs
Normal file
@ -0,0 +1,81 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.Either (rights)
|
||||
import qualified Data.Text as T
|
||||
import qualified Ide.Plugin.GADT as GADT
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hls
|
||||
|
||||
main :: IO ()
|
||||
main = defaultTestRunner tests
|
||||
|
||||
gadtPlugin :: PluginDescriptor IdeState
|
||||
gadtPlugin = GADT.descriptor "GADT"
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "GADT"
|
||||
[ runTest "range" "SimpleData" 2 0 2 1
|
||||
, runTest "SimpleData" "SimpleData" 2 0 2 10
|
||||
, runTest "SimpleNewtype" "SimpleNewtype" 2 0 2 17
|
||||
, runTest "Data" "Data" 2 0 2 36
|
||||
, runTest "Newtype" "Newtype" 2 0 2 21
|
||||
, runTest "Deriving" "Deriving" 2 0 2 56
|
||||
, runTest "Infix" "Infix" 2 0 2 35
|
||||
, runTest "Record" "Record" 2 0 5 1
|
||||
, runTest "TypeVariable" "TypeVariable" 2 0 2 32
|
||||
, runTest "DataContext" "DataContext" 2 0 2 31
|
||||
, runTest "DataContextParen" "DataContextParen" 2 0 3 6
|
||||
, runTest "Forall" "Forall" 2 0 2 44
|
||||
, runTest "ConstuctorContext" "ConstructorContext" 2 0 2 38
|
||||
, runTest "Context" "Context" 2 0 4 41
|
||||
, runTest "Pragma" "Pragma" 2 0 3 29
|
||||
, onlyWorkForGhcVersions [GHC92] "Single deriving has different output on ghc9.2" $
|
||||
runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14
|
||||
, knownBrokenForGhcVersions [GHC92] "Single deriving has different output on ghc9.2" $
|
||||
runTest "SingleDeriving" "SingleDeriving" 2 0 3 14
|
||||
, onlyWorkForGhcVersions [GHC92] "only ghc-9.2 enabled GADTs pragma implicitly" $
|
||||
gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False
|
||||
, knownBrokenForGhcVersions [GHC92] "ghc-9.2 has enabled GADTs pragma implicitly" $
|
||||
gadtPragmaTest "insert pragma" True
|
||||
]
|
||||
|
||||
gadtPragmaTest :: TestName -> Bool -> TestTree
|
||||
gadtPragmaTest title hasGADT = testCase title
|
||||
$ withCanonicalTempDir
|
||||
$ \dir -> runSessionWithServer gadtPlugin dir $ do
|
||||
doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"])
|
||||
_ <- waitForProgressDone
|
||||
(act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1))
|
||||
executeCodeAction act
|
||||
let expected = T.unlines $
|
||||
["{-# LANGUAGE GADTs #-}" | hasGADT] ++
|
||||
["module A where", "data Foo where", " Bar :: Foo"]
|
||||
contents <- skipManyTill anyMessage (getDocumentEdit doc)
|
||||
liftIO $ contents @?= expected
|
||||
|
||||
runTest :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree
|
||||
runTest title fp x1 y1 x2 y2 =
|
||||
goldenWithHaskellDoc gadtPlugin title testDataDir fp "expected" "hs" $ \doc -> do
|
||||
_ <- waitForProgressDone
|
||||
(act:_) <- findGADTAction <$> getCodeActions doc (Range (Position x1 y1) (Position x2 y2))
|
||||
executeCodeAction act
|
||||
void $ skipManyTill anyMessage (getDocumentEdit doc)
|
||||
|
||||
findGADTAction :: [a |? CodeAction] -> [CodeAction]
|
||||
findGADTAction = filter isGADTCodeAction . rights . map toEither
|
||||
|
||||
isGADTCodeAction :: CodeAction -> Bool
|
||||
isGADTCodeAction CodeAction{..} = case _kind of
|
||||
Nothing -> False
|
||||
Just kind -> case kind of
|
||||
CodeActionRefactorRewrite -> True
|
||||
_ -> False
|
||||
|
||||
testDataDir :: FilePath
|
||||
testDataDir = "test" </> "testdata"
|
4
plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module ConstructorContext where
|
||||
|
||||
data Foo where
|
||||
Bar :: Show a => a -> Foo
|
3
plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module ConstructorContext where
|
||||
|
||||
data Foo = forall a. (Show a) => Bar a
|
5
plugins/hls-gadt-plugin/test/testdata/Context.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/Context.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module Context where
|
||||
|
||||
data Foo a where
|
||||
Bar :: (Eq a, Show b, Show a) => a -> b -> Foo a
|
||||
Baz :: (Eq a, Show c) => c -> c -> Foo a
|
5
plugins/hls-gadt-plugin/test/testdata/Context.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/Context.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module Context where
|
||||
|
||||
data (Eq a) => Foo a =
|
||||
forall b c. (Show b, Show a) =>
|
||||
Bar a b | forall c. (Show c) => Baz c c
|
5
plugins/hls-gadt-plugin/test/testdata/Data.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/Data.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module Data where
|
||||
|
||||
data Foo where
|
||||
Bar :: Int -> Foo
|
||||
Baz :: Char -> String -> Foo
|
3
plugins/hls-gadt-plugin/test/testdata/Data.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/Data.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module Data where
|
||||
|
||||
data Foo = Bar Int | Baz Char String
|
5
plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module DataContext where
|
||||
|
||||
data T a b where
|
||||
F :: Ord a => a -> T a b
|
||||
G :: Ord a => b -> T a b
|
3
plugins/hls-gadt-plugin/test/testdata/DataContext.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/DataContext.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module DataContext where
|
||||
|
||||
data Ord a => T a b = F a | G b
|
4
plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module DataContextParen where
|
||||
|
||||
data F a where
|
||||
G :: Eq a => a -> F a
|
4
plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module DataContextParen where
|
||||
|
||||
data (Eq a) => F a
|
||||
= G a
|
6
plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs
vendored
Normal file
6
plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
module Deriving where
|
||||
|
||||
data Foo where
|
||||
Bar :: Int -> Foo
|
||||
Baz :: Char -> String -> Foo
|
||||
deriving (Show, Eq)
|
3
plugins/hls-gadt-plugin/test/testdata/Deriving.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/Deriving.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module Deriving where
|
||||
|
||||
data Foo = Bar Int | Baz Char String deriving (Show, Eq)
|
4
plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module Forall where
|
||||
|
||||
data Foo where
|
||||
Bar :: Show a => a -> b -> a -> Foo
|
3
plugins/hls-gadt-plugin/test/testdata/Forall.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/Forall.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module Forall where
|
||||
|
||||
data Foo = forall a b. (Show a) => Bar a b a
|
5
plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module Infix where
|
||||
|
||||
data Foo where
|
||||
(:->) :: Int -> Char -> Foo
|
||||
deriving ()
|
3
plugins/hls-gadt-plugin/test/testdata/Infix.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/Infix.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module Infix where
|
||||
|
||||
data Foo = Int :-> Char deriving ()
|
4
plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module Newtype where
|
||||
|
||||
newtype Foo where
|
||||
Bar :: Int -> Foo
|
3
plugins/hls-gadt-plugin/test/testdata/Newtype.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/Newtype.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module Newtype where
|
||||
|
||||
newtype Foo = Bar Int
|
5
plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module Pragma where
|
||||
|
||||
data F where
|
||||
G :: {-# UNPACK #-}Int -> F
|
||||
H :: {-# NOUNPACK #-}Char -> F
|
4
plugins/hls-gadt-plugin/test/testdata/Pragma.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/Pragma.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module Pragma where
|
||||
|
||||
data F = G{-# UNPACK #-}Int
|
||||
| H {-# NOUNPACK #-} Char
|
4
plugins/hls-gadt-plugin/test/testdata/Record.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/Record.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module Record where
|
||||
|
||||
data Foo where
|
||||
Foo :: {bar :: Char, baz :: Int} -> Foo
|
6
plugins/hls-gadt-plugin/test/testdata/Record.hs
vendored
Normal file
6
plugins/hls-gadt-plugin/test/testdata/Record.hs
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
module Record where
|
||||
|
||||
data Foo = Foo {
|
||||
bar :: Char,
|
||||
baz :: Int
|
||||
}
|
4
plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module SimpleData where
|
||||
|
||||
data A where
|
||||
B :: A
|
3
plugins/hls-gadt-plugin/test/testdata/SimpleData.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/SimpleData.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module SimpleData where
|
||||
|
||||
data A = B
|
4
plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module SimpleNewtype where
|
||||
|
||||
newtype A where
|
||||
B :: Int -> A
|
3
plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module SimpleNewtype where
|
||||
|
||||
newtype A = B Int
|
5
plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module SingleDeriving where
|
||||
|
||||
data Foo a b where
|
||||
Bar :: b -> a -> Foo a b
|
||||
deriving Eq
|
4
plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module SingleDeriving where
|
||||
|
||||
data Foo a b = Bar b a
|
||||
deriving (Eq)
|
5
plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module SingleDerivingGHC92 where
|
||||
|
||||
data Foo a b where
|
||||
Bar :: b -> a -> Foo a b
|
||||
deriving (Eq)
|
4
plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs
vendored
Normal file
4
plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module SingleDerivingGHC92 where
|
||||
|
||||
data Foo a b = Bar b a
|
||||
deriving (Eq)
|
5
plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs
vendored
Normal file
5
plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
module TypeVariable where
|
||||
|
||||
data Foo a f where
|
||||
Foo :: a -> Foo a f
|
||||
Bar :: (f a) -> Foo a f
|
3
plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
module TypeVariable where
|
||||
|
||||
data Foo a f = Foo a | Bar (f a)
|
3
plugins/hls-gadt-plugin/test/testdata/hie.yaml
vendored
Normal file
3
plugins/hls-gadt-plugin/test/testdata/hie.yaml
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
cradle:
|
||||
direct:
|
||||
arguments: ["-XHaskell2010", "-XExistentialQuantification", "-XGADTs"]
|
@ -30,6 +30,7 @@ packages:
|
||||
- ./plugins/hls-alternate-number-format-plugin
|
||||
- ./plugins/hls-selection-range-plugin
|
||||
- ./plugins/hls-change-type-signature-plugin
|
||||
- ./plugins/hls-gadt-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
@ -30,6 +30,7 @@ packages:
|
||||
- ./plugins/hls-alternate-number-format-plugin
|
||||
- ./plugins/hls-selection-range-plugin
|
||||
- ./plugins/hls-change-type-signature-plugin
|
||||
- ./plugins/hls-gadt-plugin
|
||||
|
||||
ghc-options:
|
||||
"$everything": -haddock
|
||||
|
@ -31,6 +31,7 @@ packages:
|
||||
- ./plugins/hls-alternate-number-format-plugin
|
||||
- ./plugins/hls-selection-range-plugin
|
||||
- ./plugins/hls-change-type-signature-plugin
|
||||
- ./plugins/hls-gadt-plugin
|
||||
|
||||
extra-deps:
|
||||
- Chart-1.9.3@sha256:640a38463318b070d80a049577e4f0b3322df98290abb7afcf0cb74a4ad5b512,2948
|
||||
|
Loading…
Reference in New Issue
Block a user