diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 41552cf49..249e0de15 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -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 diff --git a/CODEOWNERS b/CODEOWNERS index 7d12e86a7..62cd8878b 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -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 diff --git a/cabal.project b/cabal.project index c4d3e08b8..6a392d90e 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/docs/features.md b/docs/features.md index acc3d85fa..0bf1d1648 100644 --- a/docs/features.md +++ b/docs/features.md @@ -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 diff --git a/docs/supported-versions.md b/docs/supported-versions.md index 87fd819b5..21341049d 100644 --- a/docs/supported-versions.md +++ b/docs/supported-versions.md @@ -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 diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 05ccc8fb2..36e6c7f6d 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5fc524b9d..49af0c5c5 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -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 diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 345d5e15f..216ea394a 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -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) -- --------------------------------------------------------------------- diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index eab8fb831..519e15caf 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -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' diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index dc2a6cec5..ba6f86484 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -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' diff --git a/plugins/hls-gadt-plugin/LICENSE b/plugins/hls-gadt-plugin/LICENSE new file mode 100644 index 000000000..261eeb9e9 --- /dev/null +++ b/plugins/hls-gadt-plugin/LICENSE @@ -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. diff --git a/plugins/hls-gadt-plugin/README.md b/plugins/hls-gadt-plugin/README.md new file mode 100644 index 000000000..de37ea9b5 --- /dev/null +++ b/plugins/hls-gadt-plugin/README.md @@ -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 diff --git a/plugins/hls-gadt-plugin/gadt.gif b/plugins/hls-gadt-plugin/gadt.gif new file mode 100644 index 000000000..4378c5d5b Binary files /dev/null and b/plugins/hls-gadt-plugin/gadt.gif differ diff --git a/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal new file mode 100644 index 000000000..23fac32e3 --- /dev/null +++ b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal @@ -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 + +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 diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs new file mode 100644 index 000000000..478ed94e8 --- /dev/null +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs new file mode 100644 index 000000000..1a59ec208 --- /dev/null +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/test/Main.hs b/plugins/hls-gadt-plugin/test/Main.hs new file mode 100644 index 000000000..58c23422a --- /dev/null +++ b/plugins/hls-gadt-plugin/test/Main.hs @@ -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" diff --git a/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs new file mode 100644 index 000000000..1a2349539 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.expected.hs @@ -0,0 +1,4 @@ +module ConstructorContext where + +data Foo where + Bar :: Show a => a -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs new file mode 100644 index 000000000..2becd24bb --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/ConstructorContext.hs @@ -0,0 +1,3 @@ +module ConstructorContext where + +data Foo = forall a. (Show a) => Bar a diff --git a/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs new file mode 100644 index 000000000..b6a8e6e46 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Context.expected.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/test/testdata/Context.hs b/plugins/hls-gadt-plugin/test/testdata/Context.hs new file mode 100644 index 000000000..a8eff3ee0 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Context.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs new file mode 100644 index 000000000..37f42e745 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Data.expected.hs @@ -0,0 +1,5 @@ +module Data where + +data Foo where + Bar :: Int -> Foo + Baz :: Char -> String -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Data.hs b/plugins/hls-gadt-plugin/test/testdata/Data.hs new file mode 100644 index 000000000..4c2c4fd7b --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Data.hs @@ -0,0 +1,3 @@ +module Data where + +data Foo = Bar Int | Baz Char String diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs b/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs new file mode 100644 index 000000000..2cadc9d0a --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContext.expected.hs @@ -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 diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContext.hs b/plugins/hls-gadt-plugin/test/testdata/DataContext.hs new file mode 100644 index 000000000..44a697067 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContext.hs @@ -0,0 +1,3 @@ +module DataContext where + +data Ord a => T a b = F a | G b diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs new file mode 100644 index 000000000..2a0e998e5 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.expected.hs @@ -0,0 +1,4 @@ +module DataContextParen where + +data F a where + G :: Eq a => a -> F a diff --git a/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs new file mode 100644 index 000000000..63e245d73 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/DataContextParen.hs @@ -0,0 +1,4 @@ +module DataContextParen where + +data (Eq a) => F a + = G a diff --git a/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs new file mode 100644 index 000000000..1c039ef80 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Deriving.expected.hs @@ -0,0 +1,6 @@ +module Deriving where + +data Foo where + Bar :: Int -> Foo + Baz :: Char -> String -> Foo + deriving (Show, Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/Deriving.hs b/plugins/hls-gadt-plugin/test/testdata/Deriving.hs new file mode 100644 index 000000000..8a75a7d7d --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Deriving.hs @@ -0,0 +1,3 @@ +module Deriving where + +data Foo = Bar Int | Baz Char String deriving (Show, Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs new file mode 100644 index 000000000..f410a9da5 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Forall.expected.hs @@ -0,0 +1,4 @@ +module Forall where + +data Foo where + Bar :: Show a => a -> b -> a -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Forall.hs b/plugins/hls-gadt-plugin/test/testdata/Forall.hs new file mode 100644 index 000000000..ebf163029 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Forall.hs @@ -0,0 +1,3 @@ +module Forall where + +data Foo = forall a b. (Show a) => Bar a b a diff --git a/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs new file mode 100644 index 000000000..0f1c0838d --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Infix.expected.hs @@ -0,0 +1,5 @@ +module Infix where + +data Foo where + (:->) :: Int -> Char -> Foo + deriving () diff --git a/plugins/hls-gadt-plugin/test/testdata/Infix.hs b/plugins/hls-gadt-plugin/test/testdata/Infix.hs new file mode 100644 index 000000000..45d6707f7 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Infix.hs @@ -0,0 +1,3 @@ +module Infix where + +data Foo = Int :-> Char deriving () diff --git a/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs new file mode 100644 index 000000000..bd2a4edf7 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Newtype.expected.hs @@ -0,0 +1,4 @@ +module Newtype where + +newtype Foo where + Bar :: Int -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Newtype.hs b/plugins/hls-gadt-plugin/test/testdata/Newtype.hs new file mode 100644 index 000000000..fb2765f2f --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Newtype.hs @@ -0,0 +1,3 @@ +module Newtype where + +newtype Foo = Bar Int diff --git a/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs new file mode 100644 index 000000000..fe9504055 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Pragma.expected.hs @@ -0,0 +1,5 @@ +module Pragma where + +data F where + G :: {-# UNPACK #-}Int -> F + H :: {-# NOUNPACK #-}Char -> F diff --git a/plugins/hls-gadt-plugin/test/testdata/Pragma.hs b/plugins/hls-gadt-plugin/test/testdata/Pragma.hs new file mode 100644 index 000000000..5624a6a6e --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Pragma.hs @@ -0,0 +1,4 @@ +module Pragma where + +data F = G{-# UNPACK #-}Int + | H {-# NOUNPACK #-} Char diff --git a/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs b/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs new file mode 100644 index 000000000..db599fa3a --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Record.expected.hs @@ -0,0 +1,4 @@ +module Record where + +data Foo where + Foo :: {bar :: Char, baz :: Int} -> Foo diff --git a/plugins/hls-gadt-plugin/test/testdata/Record.hs b/plugins/hls-gadt-plugin/test/testdata/Record.hs new file mode 100644 index 000000000..cc46115e5 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/Record.hs @@ -0,0 +1,6 @@ +module Record where + +data Foo = Foo { + bar :: Char, + baz :: Int +} diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs new file mode 100644 index 000000000..f8c4714c2 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleData.expected.hs @@ -0,0 +1,4 @@ +module SimpleData where + +data A where + B :: A diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs new file mode 100644 index 000000000..0112eb99f --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleData.hs @@ -0,0 +1,3 @@ +module SimpleData where + +data A = B diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs new file mode 100644 index 000000000..718599b6c --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.expected.hs @@ -0,0 +1,4 @@ +module SimpleNewtype where + +newtype A where + B :: Int -> A diff --git a/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs new file mode 100644 index 000000000..e5bd15476 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SimpleNewtype.hs @@ -0,0 +1,3 @@ +module SimpleNewtype where + +newtype A = B Int diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs new file mode 100644 index 000000000..5a8d088c5 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs @@ -0,0 +1,5 @@ +module SingleDeriving where + +data Foo a b where + Bar :: b -> a -> Foo a b + deriving Eq diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs new file mode 100644 index 000000000..00cff15e9 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDeriving.hs @@ -0,0 +1,4 @@ +module SingleDeriving where + +data Foo a b = Bar b a + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs new file mode 100644 index 000000000..46ea2c7b4 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.expected.hs @@ -0,0 +1,5 @@ +module SingleDerivingGHC92 where + +data Foo a b where + Bar :: b -> a -> Foo a b + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs new file mode 100644 index 000000000..d9ff28ae8 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/SingleDerivingGHC92.hs @@ -0,0 +1,4 @@ +module SingleDerivingGHC92 where + +data Foo a b = Bar b a + deriving (Eq) diff --git a/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs new file mode 100644 index 000000000..5c2442be3 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.expected.hs @@ -0,0 +1,5 @@ +module TypeVariable where + +data Foo a f where + Foo :: a -> Foo a f + Bar :: (f a) -> Foo a f diff --git a/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs new file mode 100644 index 000000000..d7458ae4a --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/TypeVariable.hs @@ -0,0 +1,3 @@ +module TypeVariable where + +data Foo a f = Foo a | Bar (f a) diff --git a/plugins/hls-gadt-plugin/test/testdata/hie.yaml b/plugins/hls-gadt-plugin/test/testdata/hie.yaml new file mode 100644 index 000000000..e678c9223 --- /dev/null +++ b/plugins/hls-gadt-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: ["-XHaskell2010", "-XExistentialQuantification", "-XGADTs"] diff --git a/stack-lts16.yaml b/stack-lts16.yaml index ee471e352..6d4189fb6 100644 --- a/stack-lts16.yaml +++ b/stack-lts16.yaml @@ -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 diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 3ea5eee80..c877f9306 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -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 diff --git a/stack.yaml b/stack.yaml index fb26dde3d..b5b6d2153 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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